1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code
*head
, *current
;
48 struct code_stack
*prev
;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels
;
57 static code_stack
*cs_base
= NULL
;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag
;
63 static int do_concurrent_flag
;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg
= false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg
= false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag
;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag
= 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr
= false;
84 /* The id of the last entry seen. */
85 static int current_entry_id
;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack
;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument
= false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag
;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
104 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
120 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
125 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type '%s' used at %L",
129 ts
->u
.derived
->name
, where
);
140 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
142 /* Several checks for F08:C1216. */
143 if (ifc
->attr
.procedure
)
145 gfc_error ("Interface '%s' at %L is declared "
146 "in a later PROCEDURE statement", ifc
->name
, where
);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface
*gen
= ifc
->generic
;
154 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
158 gfc_error ("Interface '%s' at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface '%s' at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
170 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
171 ifc
->attr
.intrinsic
= 1;
172 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
174 gfc_error ("Intrinsic procedure '%s' not allowed in "
175 "PROCEDURE statement at %L", ifc
->name
, where
);
178 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
180 gfc_error ("Interface '%s' at %L must be explicit", ifc
->name
, where
);
187 static void resolve_symbol (gfc_symbol
*sym
);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol
*sym
)
195 gfc_symbol
*ifc
= sym
->ts
.interface
;
202 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
203 sym
->name
, &sym
->declared_at
);
206 if (!check_proc_interface (ifc
, &sym
->declared_at
))
209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc
);
213 if (ifc
->attr
.intrinsic
)
214 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
218 sym
->ts
= ifc
->result
->ts
;
223 sym
->ts
.interface
= ifc
;
224 sym
->attr
.function
= ifc
->attr
.function
;
225 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.pure
= ifc
->attr
.pure
;
230 sym
->attr
.elemental
= ifc
->attr
.elemental
;
231 sym
->attr
.dimension
= ifc
->attr
.dimension
;
232 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
233 sym
->attr
.recursive
= ifc
->attr
.recursive
;
234 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
235 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
236 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
237 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
238 /* Copy array spec. */
239 sym
->as
= gfc_copy_array_spec (ifc
->as
);
240 /* Copy char length. */
241 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
243 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
244 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
245 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol
*proc
)
266 gfc_formal_arglist
*f
;
268 bool saved_specification_expr
;
271 if (proc
->result
!= NULL
)
276 if (gfc_elemental (proc
)
277 || sym
->attr
.pointer
|| sym
->attr
.allocatable
278 || (sym
->as
&& sym
->as
->rank
!= 0))
280 proc
->attr
.always_explicit
= 1;
281 sym
->attr
.always_explicit
= 1;
286 for (f
= proc
->formal
; f
; f
= f
->next
)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc
))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "'%s' at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "'%s' at %L is not allowed", proc
->name
,
305 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
306 && !resolve_procedure_interface (sym
))
309 if (strcmp (proc
->name
, sym
->name
) == 0)
311 gfc_error ("Self-referential argument "
312 "'%s' at %L is not allowed", sym
->name
,
317 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
318 resolve_formal_arglist (sym
);
320 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
322 if (sym
->attr
.flavor
== FL_UNKNOWN
)
323 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
327 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
328 && (!sym
->attr
.function
|| sym
->result
== sym
))
329 gfc_set_default_type (sym
, 1, sym
->ns
);
332 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
333 ? CLASS_DATA (sym
)->as
: sym
->as
;
335 saved_specification_expr
= specification_expr
;
336 specification_expr
= true;
337 gfc_resolve_array_spec (as
, 0);
338 specification_expr
= saved_specification_expr
;
340 /* We can't tell if an array with dimension (:) is assumed or deferred
341 shape until we know if it has the pointer or allocatable attributes.
343 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
344 && ((sym
->ts
.type
!= BT_CLASS
345 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
346 || (sym
->ts
.type
== BT_CLASS
347 && !(CLASS_DATA (sym
)->attr
.class_pointer
348 || CLASS_DATA (sym
)->attr
.allocatable
)))
349 && sym
->attr
.flavor
!= FL_PROCEDURE
)
351 as
->type
= AS_ASSUMED_SHAPE
;
352 for (i
= 0; i
< as
->rank
; i
++)
353 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
356 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
357 || (as
&& as
->type
== AS_ASSUMED_RANK
)
358 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
359 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
360 && (CLASS_DATA (sym
)->attr
.class_pointer
361 || CLASS_DATA (sym
)->attr
.allocatable
362 || CLASS_DATA (sym
)->attr
.target
))
363 || sym
->attr
.optional
)
365 proc
->attr
.always_explicit
= 1;
367 proc
->result
->attr
.always_explicit
= 1;
370 /* If the flavor is unknown at this point, it has to be a variable.
371 A procedure specification would have already set the type. */
373 if (sym
->attr
.flavor
== FL_UNKNOWN
)
374 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
383 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
384 "also be PURE", sym
->name
, &sym
->declared_at
);
388 else if (!sym
->attr
.pointer
)
390 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
393 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
394 " of pure function '%s' at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument '%s' of pure function '%s' at %L must "
399 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
403 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
406 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
407 " of pure subroutine '%s' at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
412 "must have its INTENT specified or have the "
413 "VALUE attribute", sym
->name
, proc
->name
,
419 if (proc
->attr
.implicit_pure
)
421 if (sym
->attr
.flavor
== FL_PROCEDURE
)
424 proc
->attr
.implicit_pure
= 0;
426 else if (!sym
->attr
.pointer
)
428 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
430 proc
->attr
.implicit_pure
= 0;
432 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
434 proc
->attr
.implicit_pure
= 0;
438 if (gfc_elemental (proc
))
441 if (sym
->attr
.codimension
442 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
443 && CLASS_DATA (sym
)->attr
.codimension
))
445 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
446 "procedure", sym
->name
, &sym
->declared_at
);
450 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
451 && CLASS_DATA (sym
)->as
))
453 gfc_error ("Argument '%s' of elemental procedure at %L must "
454 "be scalar", sym
->name
, &sym
->declared_at
);
458 if (sym
->attr
.allocatable
459 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->attr
.allocatable
))
462 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
463 "have the ALLOCATABLE attribute", sym
->name
,
468 if (sym
->attr
.pointer
469 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
470 && CLASS_DATA (sym
)->attr
.class_pointer
))
472 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
473 "have the POINTER attribute", sym
->name
,
478 if (sym
->attr
.flavor
== FL_PROCEDURE
)
480 gfc_error ("Dummy procedure '%s' not allowed in elemental "
481 "procedure '%s' at %L", sym
->name
, proc
->name
,
486 /* Fortran 2008 Corrigendum 1, C1290a. */
487 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
489 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
490 "have its INTENT specified or have the VALUE "
491 "attribute", sym
->name
, proc
->name
,
497 /* Each dummy shall be specified to be scalar. */
498 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
502 gfc_error ("Argument '%s' of statement function at %L must "
503 "be scalar", sym
->name
, &sym
->declared_at
);
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
510 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
512 gfc_error ("Character-valued argument '%s' of statement "
513 "function at %L must have constant length",
514 sym
->name
, &sym
->declared_at
);
524 /* Work function called when searching for symbols that have argument lists
525 associated with them. */
528 find_arglists (gfc_symbol
*sym
)
530 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
531 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
534 resolve_formal_arglist (sym
);
538 /* Given a namespace, resolve all formal argument lists within the namespace.
542 resolve_formal_arglists (gfc_namespace
*ns
)
547 gfc_traverse_ns (ns
, find_arglists
);
552 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
556 /* If this namespace is not a function or an entry master function,
558 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
559 || sym
->attr
.entry_master
)
562 /* Try to find out of what the return type is. */
563 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
565 t
= gfc_set_default_type (sym
->result
, 0, ns
);
567 if (!t
&& !sym
->result
->attr
.untyped
)
569 if (sym
->result
== sym
)
570 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
571 sym
->name
, &sym
->declared_at
);
572 else if (!sym
->result
->attr
.proc_pointer
)
573 gfc_error ("Result '%s' of contained function '%s' at %L has "
574 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
575 &sym
->result
->declared_at
);
576 sym
->result
->attr
.untyped
= 1;
580 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
581 type, lists the only ways a character length value of * can be used:
582 dummy arguments of procedures, named constants, and function results
583 in external functions. Internal function results and results of module
584 procedures are not on this list, ergo, not permitted. */
586 if (sym
->result
->ts
.type
== BT_CHARACTER
)
588 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
589 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
591 /* See if this is a module-procedure and adapt error message
594 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
595 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
597 gfc_error ("Character-valued %s '%s' at %L must not be"
599 module_proc
? _("module procedure")
600 : _("internal function"),
601 sym
->name
, &sym
->declared_at
);
607 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
608 introduce duplicates. */
611 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
613 gfc_formal_arglist
*f
, *new_arglist
;
616 for (; new_args
!= NULL
; new_args
= new_args
->next
)
618 new_sym
= new_args
->sym
;
619 /* See if this arg is already in the formal argument list. */
620 for (f
= proc
->formal
; f
; f
= f
->next
)
622 if (new_sym
== f
->sym
)
629 /* Add a new argument. Argument order is not important. */
630 new_arglist
= gfc_get_formal_arglist ();
631 new_arglist
->sym
= new_sym
;
632 new_arglist
->next
= proc
->formal
;
633 proc
->formal
= new_arglist
;
638 /* Flag the arguments that are not present in all entries. */
641 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
643 gfc_formal_arglist
*f
, *head
;
646 for (f
= proc
->formal
; f
; f
= f
->next
)
651 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
653 if (new_args
->sym
== f
->sym
)
660 f
->sym
->attr
.not_always_present
= 1;
665 /* Resolve alternate entry points. If a symbol has multiple entry points we
666 create a new master symbol for the main routine, and turn the existing
667 symbol into an entry point. */
670 resolve_entries (gfc_namespace
*ns
)
672 gfc_namespace
*old_ns
;
676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
677 static int master_count
= 0;
679 if (ns
->proc_name
== NULL
)
682 /* No need to do anything if this procedure doesn't have alternate entry
687 /* We may already have resolved alternate entry points. */
688 if (ns
->proc_name
->attr
.entry_master
)
691 /* If this isn't a procedure something has gone horribly wrong. */
692 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
694 /* Remember the current namespace. */
695 old_ns
= gfc_current_ns
;
699 /* Add the main entry point to the list of entry points. */
700 el
= gfc_get_entry_list ();
701 el
->sym
= ns
->proc_name
;
703 el
->next
= ns
->entries
;
705 ns
->proc_name
->attr
.entry
= 1;
707 /* If it is a module function, it needs to be in the right namespace
708 so that gfc_get_fake_result_decl can gather up the results. The
709 need for this arose in get_proc_name, where these beasts were
710 left in their own namespace, to keep prior references linked to
711 the entry declaration.*/
712 if (ns
->proc_name
->attr
.function
713 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
716 /* Do the same for entries where the master is not a module
717 procedure. These are retained in the module namespace because
718 of the module procedure declaration. */
719 for (el
= el
->next
; el
; el
= el
->next
)
720 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
721 && el
->sym
->attr
.mod_proc
)
725 /* Add an entry statement for it. */
732 /* Create a new symbol for the master function. */
733 /* Give the internal function a unique name (within this file).
734 Also include the function name so the user has some hope of figuring
735 out what is going on. */
736 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
737 master_count
++, ns
->proc_name
->name
);
738 gfc_get_ha_symbol (name
, &proc
);
739 gcc_assert (proc
!= NULL
);
741 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
742 if (ns
->proc_name
->attr
.subroutine
)
743 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
747 gfc_typespec
*ts
, *fts
;
748 gfc_array_spec
*as
, *fas
;
749 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
751 fas
= ns
->entries
->sym
->as
;
752 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
753 fts
= &ns
->entries
->sym
->result
->ts
;
754 if (fts
->type
== BT_UNKNOWN
)
755 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
756 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
758 ts
= &el
->sym
->result
->ts
;
760 as
= as
? as
: el
->sym
->result
->as
;
761 if (ts
->type
== BT_UNKNOWN
)
762 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
764 if (! gfc_compare_types (ts
, fts
)
765 || (el
->sym
->result
->attr
.dimension
766 != ns
->entries
->sym
->result
->attr
.dimension
)
767 || (el
->sym
->result
->attr
.pointer
768 != ns
->entries
->sym
->result
->attr
.pointer
))
770 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
771 && gfc_compare_array_spec (as
, fas
) == 0)
772 gfc_error ("Function %s at %L has entries with mismatched "
773 "array specifications", ns
->entries
->sym
->name
,
774 &ns
->entries
->sym
->declared_at
);
775 /* The characteristics need to match and thus both need to have
776 the same string length, i.e. both len=*, or both len=4.
777 Having both len=<variable> is also possible, but difficult to
778 check at compile time. */
779 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
780 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
781 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
783 && ts
->u
.cl
->length
->expr_type
784 != fts
->u
.cl
->length
->expr_type
)
786 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
787 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
788 fts
->u
.cl
->length
->value
.integer
) != 0)))
789 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
790 "entries returning variables of different "
791 "string lengths", ns
->entries
->sym
->name
,
792 &ns
->entries
->sym
->declared_at
);
797 sym
= ns
->entries
->sym
->result
;
798 /* All result types the same. */
800 if (sym
->attr
.dimension
)
801 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
802 if (sym
->attr
.pointer
)
803 gfc_add_pointer (&proc
->attr
, NULL
);
807 /* Otherwise the result will be passed through a union by
809 proc
->attr
.mixed_entry_master
= 1;
810 for (el
= ns
->entries
; el
; el
= el
->next
)
812 sym
= el
->sym
->result
;
813 if (sym
->attr
.dimension
)
815 if (el
== ns
->entries
)
816 gfc_error ("FUNCTION result %s can't be an array in "
817 "FUNCTION %s at %L", sym
->name
,
818 ns
->entries
->sym
->name
, &sym
->declared_at
);
820 gfc_error ("ENTRY result %s can't be an array in "
821 "FUNCTION %s at %L", sym
->name
,
822 ns
->entries
->sym
->name
, &sym
->declared_at
);
824 else if (sym
->attr
.pointer
)
826 if (el
== ns
->entries
)
827 gfc_error ("FUNCTION result %s can't be a POINTER in "
828 "FUNCTION %s at %L", sym
->name
,
829 ns
->entries
->sym
->name
, &sym
->declared_at
);
831 gfc_error ("ENTRY result %s can't be a POINTER in "
832 "FUNCTION %s at %L", sym
->name
,
833 ns
->entries
->sym
->name
, &sym
->declared_at
);
838 if (ts
->type
== BT_UNKNOWN
)
839 ts
= gfc_get_default_type (sym
->name
, NULL
);
843 if (ts
->kind
== gfc_default_integer_kind
)
847 if (ts
->kind
== gfc_default_real_kind
848 || ts
->kind
== gfc_default_double_kind
)
852 if (ts
->kind
== gfc_default_complex_kind
)
856 if (ts
->kind
== gfc_default_logical_kind
)
860 /* We will issue error elsewhere. */
868 if (el
== ns
->entries
)
869 gfc_error ("FUNCTION result %s can't be of type %s "
870 "in FUNCTION %s at %L", sym
->name
,
871 gfc_typename (ts
), ns
->entries
->sym
->name
,
874 gfc_error ("ENTRY result %s can't be of type %s "
875 "in FUNCTION %s at %L", sym
->name
,
876 gfc_typename (ts
), ns
->entries
->sym
->name
,
883 proc
->attr
.access
= ACCESS_PRIVATE
;
884 proc
->attr
.entry_master
= 1;
886 /* Merge all the entry point arguments. */
887 for (el
= ns
->entries
; el
; el
= el
->next
)
888 merge_argument_lists (proc
, el
->sym
->formal
);
890 /* Check the master formal arguments for any that are not
891 present in all entry points. */
892 for (el
= ns
->entries
; el
; el
= el
->next
)
893 check_argument_lists (proc
, el
->sym
->formal
);
895 /* Use the master function for the function body. */
896 ns
->proc_name
= proc
;
898 /* Finalize the new symbols. */
899 gfc_commit_symbols ();
901 /* Restore the original namespace. */
902 gfc_current_ns
= old_ns
;
906 /* Resolve common variables. */
908 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
910 gfc_symbol
*csym
= sym
;
912 for (; csym
; csym
= csym
->common_next
)
914 if (csym
->value
|| csym
->attr
.data
)
916 if (!csym
->ns
->is_block_data
)
917 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
918 "but only in BLOCK DATA initialization is "
919 "allowed", csym
->name
, &csym
->declared_at
);
920 else if (!named_common
)
921 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
922 "in a blank COMMON but initialization is only "
923 "allowed in named common blocks", csym
->name
,
927 if (UNLIMITED_POLY (csym
))
928 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
929 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
931 if (csym
->ts
.type
!= BT_DERIVED
)
934 if (!(csym
->ts
.u
.derived
->attr
.sequence
935 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
936 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
937 "has neither the SEQUENCE nor the BIND(C) "
938 "attribute", csym
->name
, &csym
->declared_at
);
939 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
940 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
941 "has an ultimate component that is "
942 "allocatable", csym
->name
, &csym
->declared_at
);
943 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
944 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
945 "may not have default initializer", csym
->name
,
948 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
949 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
953 /* Resolve common blocks. */
955 resolve_common_blocks (gfc_symtree
*common_root
)
960 if (common_root
== NULL
)
963 if (common_root
->left
)
964 resolve_common_blocks (common_root
->left
);
965 if (common_root
->right
)
966 resolve_common_blocks (common_root
->right
);
968 resolve_common_vars (common_root
->n
.common
->head
, true);
970 /* The common name is a global name - in Fortran 2003 also if it has a
971 C binding name, since Fortran 2008 only the C binding name is a global
973 if (!common_root
->n
.common
->binding_label
974 || gfc_notification_std (GFC_STD_F2008
))
976 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
977 common_root
->n
.common
->name
);
979 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
980 && gsym
->type
== GSYM_COMMON
981 && ((common_root
->n
.common
->binding_label
982 && (!gsym
->binding_label
983 || strcmp (common_root
->n
.common
->binding_label
,
984 gsym
->binding_label
) != 0))
985 || (!common_root
->n
.common
->binding_label
986 && gsym
->binding_label
)))
988 gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
989 "identifier and must thus have the same binding name "
990 "as the same-named COMMON block at %L: %s vs %s",
991 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
993 common_root
->n
.common
->binding_label
994 ? common_root
->n
.common
->binding_label
: "(blank)",
995 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
999 if (gsym
&& gsym
->type
!= GSYM_COMMON
1000 && !common_root
->n
.common
->binding_label
)
1002 gfc_error ("COMMON block '%s' at %L uses the same global identifier "
1004 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1008 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1010 gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
1011 "%L sharing the identifier with global non-COMMON-block "
1012 "entity at %L", common_root
->n
.common
->name
,
1013 &common_root
->n
.common
->where
, &gsym
->where
);
1018 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1019 gsym
->type
= GSYM_COMMON
;
1020 gsym
->where
= common_root
->n
.common
->where
;
1026 if (common_root
->n
.common
->binding_label
)
1028 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1029 common_root
->n
.common
->binding_label
);
1030 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1032 gfc_error ("COMMON block at %L with binding label %s uses the same "
1033 "global identifier as entity at %L",
1034 &common_root
->n
.common
->where
,
1035 common_root
->n
.common
->binding_label
, &gsym
->where
);
1040 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1041 gsym
->type
= GSYM_COMMON
;
1042 gsym
->where
= common_root
->n
.common
->where
;
1048 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1052 if (sym
->attr
.flavor
== FL_PARAMETER
)
1053 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
1054 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1056 if (sym
->attr
.external
)
1057 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
1058 sym
->name
, &common_root
->n
.common
->where
);
1060 if (sym
->attr
.intrinsic
)
1061 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
1062 sym
->name
, &common_root
->n
.common
->where
);
1063 else if (sym
->attr
.result
1064 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1065 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1066 "that is also a function result", sym
->name
,
1067 &common_root
->n
.common
->where
);
1068 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1069 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1070 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1071 "that is also a global procedure", sym
->name
,
1072 &common_root
->n
.common
->where
);
1076 /* Resolve contained function types. Because contained functions can call one
1077 another, they have to be worked out before any of the contained procedures
1080 The good news is that if a function doesn't already have a type, the only
1081 way it can get one is through an IMPLICIT type or a RESULT variable, because
1082 by definition contained functions are contained namespace they're contained
1083 in, not in a sibling or parent namespace. */
1086 resolve_contained_functions (gfc_namespace
*ns
)
1088 gfc_namespace
*child
;
1091 resolve_formal_arglists (ns
);
1093 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1095 /* Resolve alternate entry points first. */
1096 resolve_entries (child
);
1098 /* Then check function return types. */
1099 resolve_contained_fntype (child
->proc_name
, child
);
1100 for (el
= child
->entries
; el
; el
= el
->next
)
1101 resolve_contained_fntype (el
->sym
, child
);
1106 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1109 /* Resolve all of the elements of a structure constructor and make sure that
1110 the types are correct. The 'init' flag indicates that the given
1111 constructor is an initializer. */
1114 resolve_structure_cons (gfc_expr
*expr
, int init
)
1116 gfc_constructor
*cons
;
1117 gfc_component
*comp
;
1123 if (expr
->ts
.type
== BT_DERIVED
)
1124 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1126 cons
= gfc_constructor_first (expr
->value
.constructor
);
1128 /* A constructor may have references if it is the result of substituting a
1129 parameter variable. In this case we just pull out the component we
1132 comp
= expr
->ref
->u
.c
.sym
->components
;
1134 comp
= expr
->ts
.u
.derived
->components
;
1136 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1143 if (!gfc_resolve_expr (cons
->expr
))
1149 rank
= comp
->as
? comp
->as
->rank
: 0;
1150 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1151 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1153 gfc_error ("The rank of the element in the structure "
1154 "constructor at %L does not match that of the "
1155 "component (%d/%d)", &cons
->expr
->where
,
1156 cons
->expr
->rank
, rank
);
1160 /* If we don't have the right type, try to convert it. */
1162 if (!comp
->attr
.proc_pointer
&&
1163 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1165 if (strcmp (comp
->name
, "_extends") == 0)
1167 /* Can afford to be brutal with the _extends initializer.
1168 The derived type can get lost because it is PRIVATE
1169 but it is not usage constrained by the standard. */
1170 cons
->expr
->ts
= comp
->ts
;
1172 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1174 gfc_error ("The element in the structure constructor at %L, "
1175 "for pointer component '%s', is %s but should be %s",
1176 &cons
->expr
->where
, comp
->name
,
1177 gfc_basic_typename (cons
->expr
->ts
.type
),
1178 gfc_basic_typename (comp
->ts
.type
));
1183 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1189 /* For strings, the length of the constructor should be the same as
1190 the one of the structure, ensure this if the lengths are known at
1191 compile time and when we are dealing with PARAMETER or structure
1193 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1194 && comp
->ts
.u
.cl
->length
1195 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1196 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1197 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1198 && cons
->expr
->rank
!= 0
1199 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1200 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1202 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1203 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1205 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1206 to make use of the gfc_resolve_character_array_constructor
1207 machinery. The expression is later simplified away to
1208 an array of string literals. */
1209 gfc_expr
*para
= cons
->expr
;
1210 cons
->expr
= gfc_get_expr ();
1211 cons
->expr
->ts
= para
->ts
;
1212 cons
->expr
->where
= para
->where
;
1213 cons
->expr
->expr_type
= EXPR_ARRAY
;
1214 cons
->expr
->rank
= para
->rank
;
1215 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1216 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1217 para
, &cons
->expr
->where
);
1219 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1222 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1223 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1225 gfc_charlen
*cl
, *cl2
;
1228 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1230 if (cl
== cons
->expr
->ts
.u
.cl
)
1238 cl2
->next
= cl
->next
;
1240 gfc_free_expr (cl
->length
);
1244 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1245 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1246 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1247 gfc_resolve_character_array_constructor (cons
->expr
);
1251 if (cons
->expr
->expr_type
== EXPR_NULL
1252 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1253 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1254 || (comp
->ts
.type
== BT_CLASS
1255 && (CLASS_DATA (comp
)->attr
.class_pointer
1256 || CLASS_DATA (comp
)->attr
.allocatable
))))
1259 gfc_error ("The NULL in the structure constructor at %L is "
1260 "being applied to component '%s', which is neither "
1261 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1265 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1267 /* Check procedure pointer interface. */
1268 gfc_symbol
*s2
= NULL
;
1273 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1276 s2
= c2
->ts
.interface
;
1279 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1281 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1282 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1284 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1286 s2
= cons
->expr
->symtree
->n
.sym
;
1287 name
= cons
->expr
->symtree
->n
.sym
->name
;
1290 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1291 err
, sizeof (err
), NULL
, NULL
))
1293 gfc_error ("Interface mismatch for procedure-pointer component "
1294 "'%s' in structure constructor at %L: %s",
1295 comp
->name
, &cons
->expr
->where
, err
);
1300 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1301 || cons
->expr
->expr_type
== EXPR_NULL
)
1304 a
= gfc_expr_attr (cons
->expr
);
1306 if (!a
.pointer
&& !a
.target
)
1309 gfc_error ("The element in the structure constructor at %L, "
1310 "for pointer component '%s' should be a POINTER or "
1311 "a TARGET", &cons
->expr
->where
, comp
->name
);
1316 /* F08:C461. Additional checks for pointer initialization. */
1320 gfc_error ("Pointer initialization target at %L "
1321 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1326 gfc_error ("Pointer initialization target at %L "
1327 "must have the SAVE attribute", &cons
->expr
->where
);
1331 /* F2003, C1272 (3). */
1332 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1333 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1334 || gfc_is_coindexed (cons
->expr
)))
1337 gfc_error ("Invalid expression in the structure constructor for "
1338 "pointer component '%s' at %L in PURE procedure",
1339 comp
->name
, &cons
->expr
->where
);
1342 if (gfc_implicit_pure (NULL
)
1343 && cons
->expr
->expr_type
== EXPR_VARIABLE
1344 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1345 || gfc_is_coindexed (cons
->expr
)))
1346 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1354 /****************** Expression name resolution ******************/
1356 /* Returns 0 if a symbol was not declared with a type or
1357 attribute declaration statement, nonzero otherwise. */
1360 was_declared (gfc_symbol
*sym
)
1366 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1369 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1370 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1371 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1372 || a
.asynchronous
|| a
.codimension
)
1379 /* Determine if a symbol is generic or not. */
1382 generic_sym (gfc_symbol
*sym
)
1386 if (sym
->attr
.generic
||
1387 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1390 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1393 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1400 return generic_sym (s
);
1407 /* Determine if a symbol is specific or not. */
1410 specific_sym (gfc_symbol
*sym
)
1414 if (sym
->attr
.if_source
== IFSRC_IFBODY
1415 || sym
->attr
.proc
== PROC_MODULE
1416 || sym
->attr
.proc
== PROC_INTERNAL
1417 || sym
->attr
.proc
== PROC_ST_FUNCTION
1418 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1419 || sym
->attr
.external
)
1422 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1425 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1427 return (s
== NULL
) ? 0 : specific_sym (s
);
1431 /* Figure out if the procedure is specific, generic or unknown. */
1434 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1438 procedure_kind (gfc_symbol
*sym
)
1440 if (generic_sym (sym
))
1441 return PTYPE_GENERIC
;
1443 if (specific_sym (sym
))
1444 return PTYPE_SPECIFIC
;
1446 return PTYPE_UNKNOWN
;
1449 /* Check references to assumed size arrays. The flag need_full_assumed_size
1450 is nonzero when matching actual arguments. */
1452 static int need_full_assumed_size
= 0;
1455 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1457 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1460 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1461 What should it be? */
1462 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1463 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1464 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1466 gfc_error ("The upper bound in the last dimension must "
1467 "appear in the reference to the assumed size "
1468 "array '%s' at %L", sym
->name
, &e
->where
);
1475 /* Look for bad assumed size array references in argument expressions
1476 of elemental and array valued intrinsic procedures. Since this is
1477 called from procedure resolution functions, it only recurses at
1481 resolve_assumed_size_actual (gfc_expr
*e
)
1486 switch (e
->expr_type
)
1489 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1494 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1495 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1506 /* Check a generic procedure, passed as an actual argument, to see if
1507 there is a matching specific name. If none, it is an error, and if
1508 more than one, the reference is ambiguous. */
1510 count_specific_procs (gfc_expr
*e
)
1517 sym
= e
->symtree
->n
.sym
;
1519 for (p
= sym
->generic
; p
; p
= p
->next
)
1520 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1522 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1528 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1532 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1533 "argument at %L", sym
->name
, &e
->where
);
1539 /* See if a call to sym could possibly be a not allowed RECURSION because of
1540 a missing RECURSIVE declaration. This means that either sym is the current
1541 context itself, or sym is the parent of a contained procedure calling its
1542 non-RECURSIVE containing procedure.
1543 This also works if sym is an ENTRY. */
1546 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1548 gfc_symbol
* proc_sym
;
1549 gfc_symbol
* context_proc
;
1550 gfc_namespace
* real_context
;
1552 if (sym
->attr
.flavor
== FL_PROGRAM
1553 || sym
->attr
.flavor
== FL_DERIVED
)
1556 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1558 /* If we've got an ENTRY, find real procedure. */
1559 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1560 proc_sym
= sym
->ns
->entries
->sym
;
1564 /* If sym is RECURSIVE, all is well of course. */
1565 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1568 /* Find the context procedure's "real" symbol if it has entries.
1569 We look for a procedure symbol, so recurse on the parents if we don't
1570 find one (like in case of a BLOCK construct). */
1571 for (real_context
= context
; ; real_context
= real_context
->parent
)
1573 /* We should find something, eventually! */
1574 gcc_assert (real_context
);
1576 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1577 : real_context
->proc_name
);
1579 /* In some special cases, there may not be a proc_name, like for this
1581 real(bad_kind()) function foo () ...
1582 when checking the call to bad_kind ().
1583 In these cases, we simply return here and assume that the
1588 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1592 /* A call from sym's body to itself is recursion, of course. */
1593 if (context_proc
== proc_sym
)
1596 /* The same is true if context is a contained procedure and sym the
1598 if (context_proc
->attr
.contained
)
1600 gfc_symbol
* parent_proc
;
1602 gcc_assert (context
->parent
);
1603 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1604 : context
->parent
->proc_name
);
1606 if (parent_proc
== proc_sym
)
1614 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1615 its typespec and formal argument list. */
1618 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1620 gfc_intrinsic_sym
* isym
= NULL
;
1626 /* Already resolved. */
1627 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1630 /* We already know this one is an intrinsic, so we don't call
1631 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1632 gfc_find_subroutine directly to check whether it is a function or
1635 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1637 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1638 isym
= gfc_intrinsic_subroutine_by_id (id
);
1640 else if (sym
->intmod_sym_id
)
1642 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1643 isym
= gfc_intrinsic_function_by_id (id
);
1645 else if (!sym
->attr
.subroutine
)
1646 isym
= gfc_find_function (sym
->name
);
1648 if (isym
&& !sym
->attr
.subroutine
)
1650 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1651 && !sym
->attr
.implicit_type
)
1652 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1653 " ignored", sym
->name
, &sym
->declared_at
);
1655 if (!sym
->attr
.function
&&
1656 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1661 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1663 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1665 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1666 " specifier", sym
->name
, &sym
->declared_at
);
1670 if (!sym
->attr
.subroutine
&&
1671 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1676 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1681 gfc_copy_formal_args_intr (sym
, isym
);
1683 /* Check it is actually available in the standard settings. */
1684 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1686 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1687 " available in the current standard settings but %s. Use"
1688 " an appropriate -std=* option or enable -fall-intrinsics"
1689 " in order to use it.",
1690 sym
->name
, &sym
->declared_at
, symstd
);
1698 /* Resolve a procedure expression, like passing it to a called procedure or as
1699 RHS for a procedure pointer assignment. */
1702 resolve_procedure_expression (gfc_expr
* expr
)
1706 if (expr
->expr_type
!= EXPR_VARIABLE
)
1708 gcc_assert (expr
->symtree
);
1710 sym
= expr
->symtree
->n
.sym
;
1712 if (sym
->attr
.intrinsic
)
1713 gfc_resolve_intrinsic (sym
, &expr
->where
);
1715 if (sym
->attr
.flavor
!= FL_PROCEDURE
1716 || (sym
->attr
.function
&& sym
->result
== sym
))
1719 /* A non-RECURSIVE procedure that is used as procedure expression within its
1720 own body is in danger of being called recursively. */
1721 if (is_illegal_recursion (sym
, gfc_current_ns
))
1722 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1723 " itself recursively. Declare it RECURSIVE or use"
1724 " -frecursive", sym
->name
, &expr
->where
);
1730 /* Resolve an actual argument list. Most of the time, this is just
1731 resolving the expressions in the list.
1732 The exception is that we sometimes have to decide whether arguments
1733 that look like procedure arguments are really simple variable
1737 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1738 bool no_formal_args
)
1741 gfc_symtree
*parent_st
;
1743 int save_need_full_assumed_size
;
1744 bool return_value
= false;
1745 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1748 first_actual_arg
= true;
1750 for (; arg
; arg
= arg
->next
)
1755 /* Check the label is a valid branching target. */
1758 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1760 gfc_error ("Label %d referenced at %L is never defined",
1761 arg
->label
->value
, &arg
->label
->where
);
1765 first_actual_arg
= false;
1769 if (e
->expr_type
== EXPR_VARIABLE
1770 && e
->symtree
->n
.sym
->attr
.generic
1772 && count_specific_procs (e
) != 1)
1775 if (e
->ts
.type
!= BT_PROCEDURE
)
1777 save_need_full_assumed_size
= need_full_assumed_size
;
1778 if (e
->expr_type
!= EXPR_VARIABLE
)
1779 need_full_assumed_size
= 0;
1780 if (!gfc_resolve_expr (e
))
1782 need_full_assumed_size
= save_need_full_assumed_size
;
1786 /* See if the expression node should really be a variable reference. */
1788 sym
= e
->symtree
->n
.sym
;
1790 if (sym
->attr
.flavor
== FL_PROCEDURE
1791 || sym
->attr
.intrinsic
1792 || sym
->attr
.external
)
1796 /* If a procedure is not already determined to be something else
1797 check if it is intrinsic. */
1798 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1799 sym
->attr
.intrinsic
= 1;
1801 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1803 gfc_error ("Statement function '%s' at %L is not allowed as an "
1804 "actual argument", sym
->name
, &e
->where
);
1807 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1808 sym
->attr
.subroutine
);
1809 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1811 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1812 "actual argument", sym
->name
, &e
->where
);
1815 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1816 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1818 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is"
1819 " used as actual argument at %L",
1820 sym
->name
, &e
->where
))
1824 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1826 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1827 "allowed as an actual argument at %L", sym
->name
,
1831 /* Check if a generic interface has a specific procedure
1832 with the same name before emitting an error. */
1833 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1836 /* Just in case a specific was found for the expression. */
1837 sym
= e
->symtree
->n
.sym
;
1839 /* If the symbol is the function that names the current (or
1840 parent) scope, then we really have a variable reference. */
1842 if (gfc_is_function_return_value (sym
, sym
->ns
))
1845 /* If all else fails, see if we have a specific intrinsic. */
1846 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1848 gfc_intrinsic_sym
*isym
;
1850 isym
= gfc_find_function (sym
->name
);
1851 if (isym
== NULL
|| !isym
->specific
)
1853 gfc_error ("Unable to find a specific INTRINSIC procedure "
1854 "for the reference '%s' at %L", sym
->name
,
1859 sym
->attr
.intrinsic
= 1;
1860 sym
->attr
.function
= 1;
1863 if (!gfc_resolve_expr (e
))
1868 /* See if the name is a module procedure in a parent unit. */
1870 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1873 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1875 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1879 if (parent_st
== NULL
)
1882 sym
= parent_st
->n
.sym
;
1883 e
->symtree
= parent_st
; /* Point to the right thing. */
1885 if (sym
->attr
.flavor
== FL_PROCEDURE
1886 || sym
->attr
.intrinsic
1887 || sym
->attr
.external
)
1889 if (!gfc_resolve_expr (e
))
1895 e
->expr_type
= EXPR_VARIABLE
;
1897 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1898 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1899 && CLASS_DATA (sym
)->as
))
1901 e
->rank
= sym
->ts
.type
== BT_CLASS
1902 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1903 e
->ref
= gfc_get_ref ();
1904 e
->ref
->type
= REF_ARRAY
;
1905 e
->ref
->u
.ar
.type
= AR_FULL
;
1906 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1907 ? CLASS_DATA (sym
)->as
: sym
->as
;
1910 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1911 primary.c (match_actual_arg). If above code determines that it
1912 is a variable instead, it needs to be resolved as it was not
1913 done at the beginning of this function. */
1914 save_need_full_assumed_size
= need_full_assumed_size
;
1915 if (e
->expr_type
!= EXPR_VARIABLE
)
1916 need_full_assumed_size
= 0;
1917 if (!gfc_resolve_expr (e
))
1919 need_full_assumed_size
= save_need_full_assumed_size
;
1922 /* Check argument list functions %VAL, %LOC and %REF. There is
1923 nothing to do for %REF. */
1924 if (arg
->name
&& arg
->name
[0] == '%')
1926 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1928 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1930 gfc_error ("By-value argument at %L is not of numeric "
1937 gfc_error ("By-value argument at %L cannot be an array or "
1938 "an array section", &e
->where
);
1942 /* Intrinsics are still PROC_UNKNOWN here. However,
1943 since same file external procedures are not resolvable
1944 in gfortran, it is a good deal easier to leave them to
1946 if (ptype
!= PROC_UNKNOWN
1947 && ptype
!= PROC_DUMMY
1948 && ptype
!= PROC_EXTERNAL
1949 && ptype
!= PROC_MODULE
)
1951 gfc_error ("By-value argument at %L is not allowed "
1952 "in this context", &e
->where
);
1957 /* Statement functions have already been excluded above. */
1958 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1959 && e
->ts
.type
== BT_PROCEDURE
)
1961 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1963 gfc_error ("Passing internal procedure at %L by location "
1964 "not allowed", &e
->where
);
1970 /* Fortran 2008, C1237. */
1971 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1972 && gfc_has_ultimate_pointer (e
))
1974 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1975 "component", &e
->where
);
1979 first_actual_arg
= false;
1982 return_value
= true;
1985 actual_arg
= actual_arg_sav
;
1986 first_actual_arg
= first_actual_arg_sav
;
1988 return return_value
;
1992 /* Do the checks of the actual argument list that are specific to elemental
1993 procedures. If called with c == NULL, we have a function, otherwise if
1994 expr == NULL, we have a subroutine. */
1997 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1999 gfc_actual_arglist
*arg0
;
2000 gfc_actual_arglist
*arg
;
2001 gfc_symbol
*esym
= NULL
;
2002 gfc_intrinsic_sym
*isym
= NULL
;
2004 gfc_intrinsic_arg
*iformal
= NULL
;
2005 gfc_formal_arglist
*eformal
= NULL
;
2006 bool formal_optional
= false;
2007 bool set_by_optional
= false;
2011 /* Is this an elemental procedure? */
2012 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2014 if (expr
->value
.function
.esym
!= NULL
2015 && expr
->value
.function
.esym
->attr
.elemental
)
2017 arg0
= expr
->value
.function
.actual
;
2018 esym
= expr
->value
.function
.esym
;
2020 else if (expr
->value
.function
.isym
!= NULL
2021 && expr
->value
.function
.isym
->elemental
)
2023 arg0
= expr
->value
.function
.actual
;
2024 isym
= expr
->value
.function
.isym
;
2029 else if (c
&& c
->ext
.actual
!= NULL
)
2031 arg0
= c
->ext
.actual
;
2033 if (c
->resolved_sym
)
2034 esym
= c
->resolved_sym
;
2036 esym
= c
->symtree
->n
.sym
;
2039 if (!esym
->attr
.elemental
)
2045 /* The rank of an elemental is the rank of its array argument(s). */
2046 for (arg
= arg0
; arg
; arg
= arg
->next
)
2048 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2050 rank
= arg
->expr
->rank
;
2051 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2052 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2053 set_by_optional
= true;
2055 /* Function specific; set the result rank and shape. */
2059 if (!expr
->shape
&& arg
->expr
->shape
)
2061 expr
->shape
= gfc_get_shape (rank
);
2062 for (i
= 0; i
< rank
; i
++)
2063 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2070 /* If it is an array, it shall not be supplied as an actual argument
2071 to an elemental procedure unless an array of the same rank is supplied
2072 as an actual argument corresponding to a nonoptional dummy argument of
2073 that elemental procedure(12.4.1.5). */
2074 formal_optional
= false;
2076 iformal
= isym
->formal
;
2078 eformal
= esym
->formal
;
2080 for (arg
= arg0
; arg
; arg
= arg
->next
)
2084 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2085 formal_optional
= true;
2086 eformal
= eformal
->next
;
2088 else if (isym
&& iformal
)
2090 if (iformal
->optional
)
2091 formal_optional
= true;
2092 iformal
= iformal
->next
;
2095 formal_optional
= true;
2097 if (pedantic
&& arg
->expr
!= NULL
2098 && arg
->expr
->expr_type
== EXPR_VARIABLE
2099 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2102 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2103 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2105 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2106 "MISSING, it cannot be the actual argument of an "
2107 "ELEMENTAL procedure unless there is a non-optional "
2108 "argument with the same rank (12.4.1.5)",
2109 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2113 for (arg
= arg0
; arg
; arg
= arg
->next
)
2115 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2118 /* Being elemental, the last upper bound of an assumed size array
2119 argument must be present. */
2120 if (resolve_assumed_size_actual (arg
->expr
))
2123 /* Elemental procedure's array actual arguments must conform. */
2126 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2133 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2134 is an array, the intent inout/out variable needs to be also an array. */
2135 if (rank
> 0 && esym
&& expr
== NULL
)
2136 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2137 arg
= arg
->next
, eformal
= eformal
->next
)
2138 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2139 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2140 && arg
->expr
&& arg
->expr
->rank
== 0)
2142 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2143 "ELEMENTAL subroutine '%s' is a scalar, but another "
2144 "actual argument is an array", &arg
->expr
->where
,
2145 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2146 : "INOUT", eformal
->sym
->name
, esym
->name
);
2153 /* This function does the checking of references to global procedures
2154 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2155 77 and 95 standards. It checks for a gsymbol for the name, making
2156 one if it does not already exist. If it already exists, then the
2157 reference being resolved must correspond to the type of gsymbol.
2158 Otherwise, the new symbol is equipped with the attributes of the
2159 reference. The corresponding code that is called in creating
2160 global entities is parse.c.
2162 In addition, for all but -std=legacy, the gsymbols are used to
2163 check the interfaces of external procedures from the same file.
2164 The namespace of the gsymbol is resolved and then, once this is
2165 done the interface is checked. */
2169 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2171 if (!gsym_ns
->proc_name
->attr
.recursive
)
2174 if (sym
->ns
== gsym_ns
)
2177 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2184 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2186 if (gsym_ns
->entries
)
2188 gfc_entry_list
*entry
= gsym_ns
->entries
;
2190 for (; entry
; entry
= entry
->next
)
2192 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2194 if (strcmp (gsym_ns
->proc_name
->name
,
2195 sym
->ns
->proc_name
->name
) == 0)
2199 && strcmp (gsym_ns
->proc_name
->name
,
2200 sym
->ns
->parent
->proc_name
->name
) == 0)
2209 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2212 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2214 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2216 for ( ; arg
; arg
= arg
->next
)
2221 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2223 strncpy (errmsg
, _("allocatable argument"), err_len
);
2226 else if (arg
->sym
->attr
.asynchronous
)
2228 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2231 else if (arg
->sym
->attr
.optional
)
2233 strncpy (errmsg
, _("optional argument"), err_len
);
2236 else if (arg
->sym
->attr
.pointer
)
2238 strncpy (errmsg
, _("pointer argument"), err_len
);
2241 else if (arg
->sym
->attr
.target
)
2243 strncpy (errmsg
, _("target argument"), err_len
);
2246 else if (arg
->sym
->attr
.value
)
2248 strncpy (errmsg
, _("value argument"), err_len
);
2251 else if (arg
->sym
->attr
.volatile_
)
2253 strncpy (errmsg
, _("volatile argument"), err_len
);
2256 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2258 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2261 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2263 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2266 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2268 strncpy (errmsg
, _("coarray argument"), err_len
);
2271 else if (false) /* (2d) TODO: parametrized derived type */
2273 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2276 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2278 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2281 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2283 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2286 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2288 /* As assumed-type is unlimited polymorphic (cf. above).
2289 See also TS 29113, Note 6.1. */
2290 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2295 if (sym
->attr
.function
)
2297 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2299 if (res
->attr
.dimension
) /* (3a) */
2301 strncpy (errmsg
, _("array result"), err_len
);
2304 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2306 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2309 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2310 && res
->ts
.u
.cl
->length
2311 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2313 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2318 if (sym
->attr
.elemental
) /* (4) */
2320 strncpy (errmsg
, _("elemental procedure"), err_len
);
2323 else if (sym
->attr
.is_bind_c
) /* (5) */
2325 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2334 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2335 gfc_actual_arglist
**actual
, int sub
)
2339 enum gfc_symbol_type type
;
2342 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2344 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2346 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2347 gfc_global_used (gsym
, where
);
2349 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2350 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2351 && gsym
->type
!= GSYM_UNKNOWN
2353 && gsym
->ns
->resolved
!= -1
2354 && gsym
->ns
->proc_name
2355 && not_in_recursive (sym
, gsym
->ns
)
2356 && not_entry_self_reference (sym
, gsym
->ns
))
2358 gfc_symbol
*def_sym
;
2360 /* Resolve the gsymbol namespace if needed. */
2361 if (!gsym
->ns
->resolved
)
2363 gfc_dt_list
*old_dt_list
;
2364 struct gfc_omp_saved_state old_omp_state
;
2366 /* Stash away derived types so that the backend_decls do not
2368 old_dt_list
= gfc_derived_types
;
2369 gfc_derived_types
= NULL
;
2370 /* And stash away openmp state. */
2371 gfc_omp_save_and_clear_state (&old_omp_state
);
2373 gfc_resolve (gsym
->ns
);
2375 /* Store the new derived types with the global namespace. */
2376 if (gfc_derived_types
)
2377 gsym
->ns
->derived_types
= gfc_derived_types
;
2379 /* Restore the derived types of this namespace. */
2380 gfc_derived_types
= old_dt_list
;
2381 /* And openmp state. */
2382 gfc_omp_restore_state (&old_omp_state
);
2385 /* Make sure that translation for the gsymbol occurs before
2386 the procedure currently being resolved. */
2387 ns
= gfc_global_ns_list
;
2388 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2390 if (ns
->sibling
== gsym
->ns
)
2392 ns
->sibling
= gsym
->ns
->sibling
;
2393 gsym
->ns
->sibling
= gfc_global_ns_list
;
2394 gfc_global_ns_list
= gsym
->ns
;
2399 def_sym
= gsym
->ns
->proc_name
;
2401 /* This can happen if a binding name has been specified. */
2402 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2403 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2405 if (def_sym
->attr
.entry_master
)
2407 gfc_entry_list
*entry
;
2408 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2409 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2411 def_sym
= entry
->sym
;
2416 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2418 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2419 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2420 gfc_typename (&def_sym
->ts
));
2424 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2425 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2427 gfc_error ("Explicit interface required for '%s' at %L: %s",
2428 sym
->name
, &sym
->declared_at
, reason
);
2432 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2433 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2434 gfc_errors_to_warnings (1);
2436 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2437 reason
, sizeof(reason
), NULL
, NULL
))
2439 gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
2440 sym
->name
, &sym
->declared_at
, reason
);
2445 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2446 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2447 gfc_errors_to_warnings (1);
2449 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2450 gfc_procedure_use (def_sym
, actual
, where
);
2454 gfc_errors_to_warnings (0);
2456 if (gsym
->type
== GSYM_UNKNOWN
)
2459 gsym
->where
= *where
;
2466 /************* Function resolution *************/
2468 /* Resolve a function call known to be generic.
2469 Section 14.1.2.4.1. */
2472 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2476 if (sym
->attr
.generic
)
2478 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2481 expr
->value
.function
.name
= s
->name
;
2482 expr
->value
.function
.esym
= s
;
2484 if (s
->ts
.type
!= BT_UNKNOWN
)
2486 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2487 expr
->ts
= s
->result
->ts
;
2490 expr
->rank
= s
->as
->rank
;
2491 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2492 expr
->rank
= s
->result
->as
->rank
;
2494 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2499 /* TODO: Need to search for elemental references in generic
2503 if (sym
->attr
.intrinsic
)
2504 return gfc_intrinsic_func_interface (expr
, 0);
2511 resolve_generic_f (gfc_expr
*expr
)
2515 gfc_interface
*intr
= NULL
;
2517 sym
= expr
->symtree
->n
.sym
;
2521 m
= resolve_generic_f0 (expr
, sym
);
2524 else if (m
== MATCH_ERROR
)
2529 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2530 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2533 if (sym
->ns
->parent
== NULL
)
2535 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2539 if (!generic_sym (sym
))
2543 /* Last ditch attempt. See if the reference is to an intrinsic
2544 that possesses a matching interface. 14.1.2.4 */
2545 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2547 gfc_error ("There is no specific function for the generic '%s' "
2548 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2554 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2557 return resolve_structure_cons (expr
, 0);
2560 m
= gfc_intrinsic_func_interface (expr
, 0);
2565 gfc_error ("Generic function '%s' at %L is not consistent with a "
2566 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2573 /* Resolve a function call known to be specific. */
2576 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2580 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2582 if (sym
->attr
.dummy
)
2584 sym
->attr
.proc
= PROC_DUMMY
;
2588 sym
->attr
.proc
= PROC_EXTERNAL
;
2592 if (sym
->attr
.proc
== PROC_MODULE
2593 || sym
->attr
.proc
== PROC_ST_FUNCTION
2594 || sym
->attr
.proc
== PROC_INTERNAL
)
2597 if (sym
->attr
.intrinsic
)
2599 m
= gfc_intrinsic_func_interface (expr
, 1);
2603 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2604 "with an intrinsic", sym
->name
, &expr
->where
);
2612 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2615 expr
->ts
= sym
->result
->ts
;
2618 expr
->value
.function
.name
= sym
->name
;
2619 expr
->value
.function
.esym
= sym
;
2620 if (sym
->as
!= NULL
)
2621 expr
->rank
= sym
->as
->rank
;
2628 resolve_specific_f (gfc_expr
*expr
)
2633 sym
= expr
->symtree
->n
.sym
;
2637 m
= resolve_specific_f0 (sym
, expr
);
2640 if (m
== MATCH_ERROR
)
2643 if (sym
->ns
->parent
== NULL
)
2646 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2652 gfc_error ("Unable to resolve the specific function '%s' at %L",
2653 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2659 /* Resolve a procedure call not known to be generic nor specific. */
2662 resolve_unknown_f (gfc_expr
*expr
)
2667 sym
= expr
->symtree
->n
.sym
;
2669 if (sym
->attr
.dummy
)
2671 sym
->attr
.proc
= PROC_DUMMY
;
2672 expr
->value
.function
.name
= sym
->name
;
2676 /* See if we have an intrinsic function reference. */
2678 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2680 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2685 /* The reference is to an external name. */
2687 sym
->attr
.proc
= PROC_EXTERNAL
;
2688 expr
->value
.function
.name
= sym
->name
;
2689 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2691 if (sym
->as
!= NULL
)
2692 expr
->rank
= sym
->as
->rank
;
2694 /* Type of the expression is either the type of the symbol or the
2695 default type of the symbol. */
2698 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2700 if (sym
->ts
.type
!= BT_UNKNOWN
)
2704 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2706 if (ts
->type
== BT_UNKNOWN
)
2708 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2709 sym
->name
, &expr
->where
);
2720 /* Return true, if the symbol is an external procedure. */
2722 is_external_proc (gfc_symbol
*sym
)
2724 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2725 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2726 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2727 && !sym
->attr
.proc_pointer
2728 && !sym
->attr
.use_assoc
2736 /* Figure out if a function reference is pure or not. Also set the name
2737 of the function for a potential error message. Return nonzero if the
2738 function is PURE, zero if not. */
2740 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2743 pure_function (gfc_expr
*e
, const char **name
)
2749 if (e
->symtree
!= NULL
2750 && e
->symtree
->n
.sym
!= NULL
2751 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2752 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2754 if (e
->value
.function
.esym
)
2756 pure
= gfc_pure (e
->value
.function
.esym
);
2757 *name
= e
->value
.function
.esym
->name
;
2759 else if (e
->value
.function
.isym
)
2761 pure
= e
->value
.function
.isym
->pure
2762 || e
->value
.function
.isym
->elemental
;
2763 *name
= e
->value
.function
.isym
->name
;
2767 /* Implicit functions are not pure. */
2769 *name
= e
->value
.function
.name
;
2777 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2778 int *f ATTRIBUTE_UNUSED
)
2782 /* Don't bother recursing into other statement functions
2783 since they will be checked individually for purity. */
2784 if (e
->expr_type
!= EXPR_FUNCTION
2786 || e
->symtree
->n
.sym
== sym
2787 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2790 return pure_function (e
, &name
) ? false : true;
2795 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2797 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2801 /* Resolve a function call, which means resolving the arguments, then figuring
2802 out which entity the name refers to. */
2805 resolve_function (gfc_expr
*expr
)
2807 gfc_actual_arglist
*arg
;
2812 procedure_type p
= PROC_INTRINSIC
;
2813 bool no_formal_args
;
2817 sym
= expr
->symtree
->n
.sym
;
2819 /* If this is a procedure pointer component, it has already been resolved. */
2820 if (gfc_is_proc_ptr_comp (expr
))
2823 if (sym
&& sym
->attr
.intrinsic
2824 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2827 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2829 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2833 /* If this ia a deferred TBP with an abstract interface (which may
2834 of course be referenced), expr->value.function.esym will be set. */
2835 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2837 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2838 sym
->name
, &expr
->where
);
2842 /* Switch off assumed size checking and do this again for certain kinds
2843 of procedure, once the procedure itself is resolved. */
2844 need_full_assumed_size
++;
2846 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2847 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2849 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2850 inquiry_argument
= true;
2851 no_formal_args
= sym
&& is_external_proc (sym
)
2852 && gfc_sym_get_dummy_args (sym
) == NULL
;
2854 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2857 inquiry_argument
= false;
2861 inquiry_argument
= false;
2863 /* Resume assumed_size checking. */
2864 need_full_assumed_size
--;
2866 /* If the procedure is external, check for usage. */
2867 if (sym
&& is_external_proc (sym
))
2868 resolve_global_procedure (sym
, &expr
->where
,
2869 &expr
->value
.function
.actual
, 0);
2871 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2873 && sym
->ts
.u
.cl
->length
== NULL
2875 && !sym
->ts
.deferred
2876 && expr
->value
.function
.esym
== NULL
2877 && !sym
->attr
.contained
)
2879 /* Internal procedures are taken care of in resolve_contained_fntype. */
2880 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2881 "be used at %L since it is not a dummy argument",
2882 sym
->name
, &expr
->where
);
2886 /* See if function is already resolved. */
2888 if (expr
->value
.function
.name
!= NULL
)
2890 if (expr
->ts
.type
== BT_UNKNOWN
)
2896 /* Apply the rules of section 14.1.2. */
2898 switch (procedure_kind (sym
))
2901 t
= resolve_generic_f (expr
);
2904 case PTYPE_SPECIFIC
:
2905 t
= resolve_specific_f (expr
);
2909 t
= resolve_unknown_f (expr
);
2913 gfc_internal_error ("resolve_function(): bad function type");
2917 /* If the expression is still a function (it might have simplified),
2918 then we check to see if we are calling an elemental function. */
2920 if (expr
->expr_type
!= EXPR_FUNCTION
)
2923 temp
= need_full_assumed_size
;
2924 need_full_assumed_size
= 0;
2926 if (!resolve_elemental_actual (expr
, NULL
))
2929 if (omp_workshare_flag
2930 && expr
->value
.function
.esym
2931 && ! gfc_elemental (expr
->value
.function
.esym
))
2933 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2934 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2939 #define GENERIC_ID expr->value.function.isym->id
2940 else if (expr
->value
.function
.actual
!= NULL
2941 && expr
->value
.function
.isym
!= NULL
2942 && GENERIC_ID
!= GFC_ISYM_LBOUND
2943 && GENERIC_ID
!= GFC_ISYM_LEN
2944 && GENERIC_ID
!= GFC_ISYM_LOC
2945 && GENERIC_ID
!= GFC_ISYM_C_LOC
2946 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2948 /* Array intrinsics must also have the last upper bound of an
2949 assumed size array argument. UBOUND and SIZE have to be
2950 excluded from the check if the second argument is anything
2953 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2955 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2956 && arg
== expr
->value
.function
.actual
2957 && arg
->next
!= NULL
&& arg
->next
->expr
)
2959 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2962 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2965 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2970 if (arg
->expr
!= NULL
2971 && arg
->expr
->rank
> 0
2972 && resolve_assumed_size_actual (arg
->expr
))
2978 need_full_assumed_size
= temp
;
2981 if (!pure_function (expr
, &name
) && name
)
2985 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2986 "FORALL %s", name
, &expr
->where
,
2987 forall_flag
== 2 ? "mask" : "block");
2990 else if (do_concurrent_flag
)
2992 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2993 "DO CONCURRENT %s", name
, &expr
->where
,
2994 do_concurrent_flag
== 2 ? "mask" : "block");
2997 else if (gfc_pure (NULL
))
2999 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3000 "procedure within a PURE procedure", name
, &expr
->where
);
3004 if (gfc_implicit_pure (NULL
))
3005 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3008 /* Functions without the RECURSIVE attribution are not allowed to
3009 * call themselves. */
3010 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3013 esym
= expr
->value
.function
.esym
;
3015 if (is_illegal_recursion (esym
, gfc_current_ns
))
3017 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3018 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3019 " function '%s' is not RECURSIVE",
3020 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3022 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3023 " is not RECURSIVE", esym
->name
, &expr
->where
);
3029 /* Character lengths of use associated functions may contains references to
3030 symbols not referenced from the current program unit otherwise. Make sure
3031 those symbols are marked as referenced. */
3033 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3034 && expr
->value
.function
.esym
->attr
.use_assoc
)
3036 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3039 /* Make sure that the expression has a typespec that works. */
3040 if (expr
->ts
.type
== BT_UNKNOWN
)
3042 if (expr
->symtree
->n
.sym
->result
3043 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3044 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3045 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3052 /************* Subroutine resolution *************/
3055 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3061 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3062 sym
->name
, &c
->loc
);
3063 else if (do_concurrent_flag
)
3064 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3065 "PURE", sym
->name
, &c
->loc
);
3066 else if (gfc_pure (NULL
))
3067 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3070 if (gfc_implicit_pure (NULL
))
3071 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3076 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3080 if (sym
->attr
.generic
)
3082 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3085 c
->resolved_sym
= s
;
3086 pure_subroutine (c
, s
);
3090 /* TODO: Need to search for elemental references in generic interface. */
3093 if (sym
->attr
.intrinsic
)
3094 return gfc_intrinsic_sub_interface (c
, 0);
3101 resolve_generic_s (gfc_code
*c
)
3106 sym
= c
->symtree
->n
.sym
;
3110 m
= resolve_generic_s0 (c
, sym
);
3113 else if (m
== MATCH_ERROR
)
3117 if (sym
->ns
->parent
== NULL
)
3119 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3123 if (!generic_sym (sym
))
3127 /* Last ditch attempt. See if the reference is to an intrinsic
3128 that possesses a matching interface. 14.1.2.4 */
3129 sym
= c
->symtree
->n
.sym
;
3131 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3133 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3134 sym
->name
, &c
->loc
);
3138 m
= gfc_intrinsic_sub_interface (c
, 0);
3142 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3143 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3149 /* Resolve a subroutine call known to be specific. */
3152 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3156 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3158 if (sym
->attr
.dummy
)
3160 sym
->attr
.proc
= PROC_DUMMY
;
3164 sym
->attr
.proc
= PROC_EXTERNAL
;
3168 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3171 if (sym
->attr
.intrinsic
)
3173 m
= gfc_intrinsic_sub_interface (c
, 1);
3177 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3178 "with an intrinsic", sym
->name
, &c
->loc
);
3186 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3188 c
->resolved_sym
= sym
;
3189 pure_subroutine (c
, sym
);
3196 resolve_specific_s (gfc_code
*c
)
3201 sym
= c
->symtree
->n
.sym
;
3205 m
= resolve_specific_s0 (c
, sym
);
3208 if (m
== MATCH_ERROR
)
3211 if (sym
->ns
->parent
== NULL
)
3214 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3220 sym
= c
->symtree
->n
.sym
;
3221 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3222 sym
->name
, &c
->loc
);
3228 /* Resolve a subroutine call not known to be generic nor specific. */
3231 resolve_unknown_s (gfc_code
*c
)
3235 sym
= c
->symtree
->n
.sym
;
3237 if (sym
->attr
.dummy
)
3239 sym
->attr
.proc
= PROC_DUMMY
;
3243 /* See if we have an intrinsic function reference. */
3245 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3247 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3252 /* The reference is to an external name. */
3255 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3257 c
->resolved_sym
= sym
;
3259 pure_subroutine (c
, sym
);
3265 /* Resolve a subroutine call. Although it was tempting to use the same code
3266 for functions, subroutines and functions are stored differently and this
3267 makes things awkward. */
3270 resolve_call (gfc_code
*c
)
3273 procedure_type ptype
= PROC_INTRINSIC
;
3274 gfc_symbol
*csym
, *sym
;
3275 bool no_formal_args
;
3277 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3279 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3281 gfc_error ("'%s' at %L has a type, which is not consistent with "
3282 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3286 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3289 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3290 sym
= st
? st
->n
.sym
: NULL
;
3291 if (sym
&& csym
!= sym
3292 && sym
->ns
== gfc_current_ns
3293 && sym
->attr
.flavor
== FL_PROCEDURE
3294 && sym
->attr
.contained
)
3297 if (csym
->attr
.generic
)
3298 c
->symtree
->n
.sym
= sym
;
3301 csym
= c
->symtree
->n
.sym
;
3305 /* If this ia a deferred TBP, c->expr1 will be set. */
3306 if (!c
->expr1
&& csym
)
3308 if (csym
->attr
.abstract
)
3310 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3311 csym
->name
, &c
->loc
);
3315 /* Subroutines without the RECURSIVE attribution are not allowed to
3317 if (is_illegal_recursion (csym
, gfc_current_ns
))
3319 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3320 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3321 "as subroutine '%s' is not RECURSIVE",
3322 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3324 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3325 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3331 /* Switch off assumed size checking and do this again for certain kinds
3332 of procedure, once the procedure itself is resolved. */
3333 need_full_assumed_size
++;
3336 ptype
= csym
->attr
.proc
;
3338 no_formal_args
= csym
&& is_external_proc (csym
)
3339 && gfc_sym_get_dummy_args (csym
) == NULL
;
3340 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3343 /* Resume assumed_size checking. */
3344 need_full_assumed_size
--;
3346 /* If external, check for usage. */
3347 if (csym
&& is_external_proc (csym
))
3348 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3351 if (c
->resolved_sym
== NULL
)
3353 c
->resolved_isym
= NULL
;
3354 switch (procedure_kind (csym
))
3357 t
= resolve_generic_s (c
);
3360 case PTYPE_SPECIFIC
:
3361 t
= resolve_specific_s (c
);
3365 t
= resolve_unknown_s (c
);
3369 gfc_internal_error ("resolve_subroutine(): bad function type");
3373 /* Some checks of elemental subroutine actual arguments. */
3374 if (!resolve_elemental_actual (NULL
, c
))
3381 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3382 op1->shape and op2->shape are non-NULL return true if their shapes
3383 match. If both op1->shape and op2->shape are non-NULL return false
3384 if their shapes do not match. If either op1->shape or op2->shape is
3385 NULL, return true. */
3388 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3395 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3397 for (i
= 0; i
< op1
->rank
; i
++)
3399 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3401 gfc_error ("Shapes for operands at %L and %L are not conformable",
3402 &op1
->where
, &op2
->where
);
3413 /* Resolve an operator expression node. This can involve replacing the
3414 operation with a user defined function call. */
3417 resolve_operator (gfc_expr
*e
)
3419 gfc_expr
*op1
, *op2
;
3421 bool dual_locus_error
;
3424 /* Resolve all subnodes-- give them types. */
3426 switch (e
->value
.op
.op
)
3429 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3432 /* Fall through... */
3435 case INTRINSIC_UPLUS
:
3436 case INTRINSIC_UMINUS
:
3437 case INTRINSIC_PARENTHESES
:
3438 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3443 /* Typecheck the new node. */
3445 op1
= e
->value
.op
.op1
;
3446 op2
= e
->value
.op
.op2
;
3447 dual_locus_error
= false;
3449 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3450 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3452 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3456 switch (e
->value
.op
.op
)
3458 case INTRINSIC_UPLUS
:
3459 case INTRINSIC_UMINUS
:
3460 if (op1
->ts
.type
== BT_INTEGER
3461 || op1
->ts
.type
== BT_REAL
3462 || op1
->ts
.type
== BT_COMPLEX
)
3468 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3469 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3472 case INTRINSIC_PLUS
:
3473 case INTRINSIC_MINUS
:
3474 case INTRINSIC_TIMES
:
3475 case INTRINSIC_DIVIDE
:
3476 case INTRINSIC_POWER
:
3477 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3479 gfc_type_convert_binary (e
, 1);
3484 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3485 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3486 gfc_typename (&op2
->ts
));
3489 case INTRINSIC_CONCAT
:
3490 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3491 && op1
->ts
.kind
== op2
->ts
.kind
)
3493 e
->ts
.type
= BT_CHARACTER
;
3494 e
->ts
.kind
= op1
->ts
.kind
;
3499 _("Operands of string concatenation operator at %%L are %s/%s"),
3500 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3506 case INTRINSIC_NEQV
:
3507 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3509 e
->ts
.type
= BT_LOGICAL
;
3510 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3511 if (op1
->ts
.kind
< e
->ts
.kind
)
3512 gfc_convert_type (op1
, &e
->ts
, 2);
3513 else if (op2
->ts
.kind
< e
->ts
.kind
)
3514 gfc_convert_type (op2
, &e
->ts
, 2);
3518 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3519 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3520 gfc_typename (&op2
->ts
));
3525 if (op1
->ts
.type
== BT_LOGICAL
)
3527 e
->ts
.type
= BT_LOGICAL
;
3528 e
->ts
.kind
= op1
->ts
.kind
;
3532 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3533 gfc_typename (&op1
->ts
));
3537 case INTRINSIC_GT_OS
:
3539 case INTRINSIC_GE_OS
:
3541 case INTRINSIC_LT_OS
:
3543 case INTRINSIC_LE_OS
:
3544 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3546 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3550 /* Fall through... */
3553 case INTRINSIC_EQ_OS
:
3555 case INTRINSIC_NE_OS
:
3556 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3557 && op1
->ts
.kind
== op2
->ts
.kind
)
3559 e
->ts
.type
= BT_LOGICAL
;
3560 e
->ts
.kind
= gfc_default_logical_kind
;
3564 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3566 gfc_type_convert_binary (e
, 1);
3568 e
->ts
.type
= BT_LOGICAL
;
3569 e
->ts
.kind
= gfc_default_logical_kind
;
3571 if (gfc_option
.warn_compare_reals
)
3573 gfc_intrinsic_op op
= e
->value
.op
.op
;
3575 /* Type conversion has made sure that the types of op1 and op2
3576 agree, so it is only necessary to check the first one. */
3577 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3578 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3579 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3583 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3584 msg
= "Equality comparison for %s at %L";
3586 msg
= "Inequality comparison for %s at %L";
3588 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3595 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3597 _("Logicals at %%L must be compared with %s instead of %s"),
3598 (e
->value
.op
.op
== INTRINSIC_EQ
3599 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3600 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3603 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3604 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3605 gfc_typename (&op2
->ts
));
3609 case INTRINSIC_USER
:
3610 if (e
->value
.op
.uop
->op
== NULL
)
3611 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3612 else if (op2
== NULL
)
3613 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3614 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3617 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3618 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3619 gfc_typename (&op2
->ts
));
3620 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3625 case INTRINSIC_PARENTHESES
:
3627 if (e
->ts
.type
== BT_CHARACTER
)
3628 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3632 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3635 /* Deal with arrayness of an operand through an operator. */
3639 switch (e
->value
.op
.op
)
3641 case INTRINSIC_PLUS
:
3642 case INTRINSIC_MINUS
:
3643 case INTRINSIC_TIMES
:
3644 case INTRINSIC_DIVIDE
:
3645 case INTRINSIC_POWER
:
3646 case INTRINSIC_CONCAT
:
3650 case INTRINSIC_NEQV
:
3652 case INTRINSIC_EQ_OS
:
3654 case INTRINSIC_NE_OS
:
3656 case INTRINSIC_GT_OS
:
3658 case INTRINSIC_GE_OS
:
3660 case INTRINSIC_LT_OS
:
3662 case INTRINSIC_LE_OS
:
3664 if (op1
->rank
== 0 && op2
->rank
== 0)
3667 if (op1
->rank
== 0 && op2
->rank
!= 0)
3669 e
->rank
= op2
->rank
;
3671 if (e
->shape
== NULL
)
3672 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3675 if (op1
->rank
!= 0 && op2
->rank
== 0)
3677 e
->rank
= op1
->rank
;
3679 if (e
->shape
== NULL
)
3680 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3683 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3685 if (op1
->rank
== op2
->rank
)
3687 e
->rank
= op1
->rank
;
3688 if (e
->shape
== NULL
)
3690 t
= compare_shapes (op1
, op2
);
3694 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3699 /* Allow higher level expressions to work. */
3702 /* Try user-defined operators, and otherwise throw an error. */
3703 dual_locus_error
= true;
3705 _("Inconsistent ranks for operator at %%L and %%L"));
3712 case INTRINSIC_PARENTHESES
:
3714 case INTRINSIC_UPLUS
:
3715 case INTRINSIC_UMINUS
:
3716 /* Simply copy arrayness attribute */
3717 e
->rank
= op1
->rank
;
3719 if (e
->shape
== NULL
)
3720 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3728 /* Attempt to simplify the expression. */
3731 t
= gfc_simplify_expr (e
, 0);
3732 /* Some calls do not succeed in simplification and return false
3733 even though there is no error; e.g. variable references to
3734 PARAMETER arrays. */
3735 if (!gfc_is_constant_expr (e
))
3743 match m
= gfc_extend_expr (e
);
3746 if (m
== MATCH_ERROR
)
3750 if (dual_locus_error
)
3751 gfc_error (msg
, &op1
->where
, &op2
->where
);
3753 gfc_error (msg
, &e
->where
);
3759 /************** Array resolution subroutines **************/
3762 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3765 /* Compare two integer expressions. */
3768 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3772 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3773 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3776 /* If either of the types isn't INTEGER, we must have
3777 raised an error earlier. */
3779 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3782 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3792 /* Compare an integer expression with an integer. */
3795 compare_bound_int (gfc_expr
*a
, int b
)
3799 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3802 if (a
->ts
.type
!= BT_INTEGER
)
3803 gfc_internal_error ("compare_bound_int(): Bad expression");
3805 i
= mpz_cmp_si (a
->value
.integer
, b
);
3815 /* Compare an integer expression with a mpz_t. */
3818 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3822 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3825 if (a
->ts
.type
!= BT_INTEGER
)
3826 gfc_internal_error ("compare_bound_int(): Bad expression");
3828 i
= mpz_cmp (a
->value
.integer
, b
);
3838 /* Compute the last value of a sequence given by a triplet.
3839 Return 0 if it wasn't able to compute the last value, or if the
3840 sequence if empty, and 1 otherwise. */
3843 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3844 gfc_expr
*stride
, mpz_t last
)
3848 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3849 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3850 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3853 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3854 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3857 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3859 if (compare_bound (start
, end
) == CMP_GT
)
3861 mpz_set (last
, end
->value
.integer
);
3865 if (compare_bound_int (stride
, 0) == CMP_GT
)
3867 /* Stride is positive */
3868 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3873 /* Stride is negative */
3874 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3879 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3880 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3881 mpz_sub (last
, end
->value
.integer
, rem
);
3888 /* Compare a single dimension of an array reference to the array
3892 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3896 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3898 gcc_assert (ar
->stride
[i
] == NULL
);
3899 /* This implies [*] as [*:] and [*:3] are not possible. */
3900 if (ar
->start
[i
] == NULL
)
3902 gcc_assert (ar
->end
[i
] == NULL
);
3907 /* Given start, end and stride values, calculate the minimum and
3908 maximum referenced indexes. */
3910 switch (ar
->dimen_type
[i
])
3913 case DIMEN_THIS_IMAGE
:
3918 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3921 gfc_warning ("Array reference at %L is out of bounds "
3922 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3923 mpz_get_si (ar
->start
[i
]->value
.integer
),
3924 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3926 gfc_warning ("Array reference at %L is out of bounds "
3927 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3928 mpz_get_si (ar
->start
[i
]->value
.integer
),
3929 mpz_get_si (as
->lower
[i
]->value
.integer
),
3933 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3936 gfc_warning ("Array reference at %L is out of bounds "
3937 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3938 mpz_get_si (ar
->start
[i
]->value
.integer
),
3939 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3941 gfc_warning ("Array reference at %L is out of bounds "
3942 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3943 mpz_get_si (ar
->start
[i
]->value
.integer
),
3944 mpz_get_si (as
->upper
[i
]->value
.integer
),
3953 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3954 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3956 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3958 /* Check for zero stride, which is not allowed. */
3959 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3961 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3965 /* if start == len || (stride > 0 && start < len)
3966 || (stride < 0 && start > len),
3967 then the array section contains at least one element. In this
3968 case, there is an out-of-bounds access if
3969 (start < lower || start > upper). */
3970 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3971 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3972 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3973 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3974 && comp_start_end
== CMP_GT
))
3976 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3978 gfc_warning ("Lower array reference at %L is out of bounds "
3979 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3980 mpz_get_si (AR_START
->value
.integer
),
3981 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3984 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3986 gfc_warning ("Lower array reference at %L is out of bounds "
3987 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3988 mpz_get_si (AR_START
->value
.integer
),
3989 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3994 /* If we can compute the highest index of the array section,
3995 then it also has to be between lower and upper. */
3996 mpz_init (last_value
);
3997 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4000 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4002 gfc_warning ("Upper array reference at %L is out of bounds "
4003 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4004 mpz_get_si (last_value
),
4005 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4006 mpz_clear (last_value
);
4009 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4011 gfc_warning ("Upper array reference at %L is out of bounds "
4012 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4013 mpz_get_si (last_value
),
4014 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4015 mpz_clear (last_value
);
4019 mpz_clear (last_value
);
4027 gfc_internal_error ("check_dimension(): Bad array reference");
4034 /* Compare an array reference with an array specification. */
4037 compare_spec_to_ref (gfc_array_ref
*ar
)
4044 /* TODO: Full array sections are only allowed as actual parameters. */
4045 if (as
->type
== AS_ASSUMED_SIZE
4046 && (/*ar->type == AR_FULL
4047 ||*/ (ar
->type
== AR_SECTION
4048 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4050 gfc_error ("Rightmost upper bound of assumed size array section "
4051 "not specified at %L", &ar
->where
);
4055 if (ar
->type
== AR_FULL
)
4058 if (as
->rank
!= ar
->dimen
)
4060 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4061 &ar
->where
, ar
->dimen
, as
->rank
);
4065 /* ar->codimen == 0 is a local array. */
4066 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4068 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4069 &ar
->where
, ar
->codimen
, as
->corank
);
4073 for (i
= 0; i
< as
->rank
; i
++)
4074 if (!check_dimension (i
, ar
, as
))
4077 /* Local access has no coarray spec. */
4078 if (ar
->codimen
!= 0)
4079 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4081 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4082 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4084 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4085 i
+ 1 - as
->rank
, &ar
->where
);
4088 if (!check_dimension (i
, ar
, as
))
4096 /* Resolve one part of an array index. */
4099 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4100 int force_index_integer_kind
)
4107 if (!gfc_resolve_expr (index
))
4110 if (check_scalar
&& index
->rank
!= 0)
4112 gfc_error ("Array index at %L must be scalar", &index
->where
);
4116 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4118 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4119 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4123 if (index
->ts
.type
== BT_REAL
)
4124 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4128 if ((index
->ts
.kind
!= gfc_index_integer_kind
4129 && force_index_integer_kind
)
4130 || index
->ts
.type
!= BT_INTEGER
)
4133 ts
.type
= BT_INTEGER
;
4134 ts
.kind
= gfc_index_integer_kind
;
4136 gfc_convert_type_warn (index
, &ts
, 2, 0);
4142 /* Resolve one part of an array index. */
4145 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4147 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4150 /* Resolve a dim argument to an intrinsic function. */
4153 gfc_resolve_dim_arg (gfc_expr
*dim
)
4158 if (!gfc_resolve_expr (dim
))
4163 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4168 if (dim
->ts
.type
!= BT_INTEGER
)
4170 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4174 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4179 ts
.type
= BT_INTEGER
;
4180 ts
.kind
= gfc_index_integer_kind
;
4182 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4188 /* Given an expression that contains array references, update those array
4189 references to point to the right array specifications. While this is
4190 filled in during matching, this information is difficult to save and load
4191 in a module, so we take care of it here.
4193 The idea here is that the original array reference comes from the
4194 base symbol. We traverse the list of reference structures, setting
4195 the stored reference to references. Component references can
4196 provide an additional array specification. */
4199 find_array_spec (gfc_expr
*e
)
4205 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4206 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4208 as
= e
->symtree
->n
.sym
->as
;
4210 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4215 gfc_internal_error ("find_array_spec(): Missing spec");
4222 c
= ref
->u
.c
.component
;
4223 if (c
->attr
.dimension
)
4226 gfc_internal_error ("find_array_spec(): unused as(1)");
4237 gfc_internal_error ("find_array_spec(): unused as(2)");
4241 /* Resolve an array reference. */
4244 resolve_array_ref (gfc_array_ref
*ar
)
4246 int i
, check_scalar
;
4249 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4251 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4253 /* Do not force gfc_index_integer_kind for the start. We can
4254 do fine with any integer kind. This avoids temporary arrays
4255 created for indexing with a vector. */
4256 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4258 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4260 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4265 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4269 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4273 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4274 if (e
->expr_type
== EXPR_VARIABLE
4275 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4276 ar
->start
[i
] = gfc_get_parentheses (e
);
4280 gfc_error ("Array index at %L is an array of rank %d",
4281 &ar
->c_where
[i
], e
->rank
);
4285 /* Fill in the upper bound, which may be lower than the
4286 specified one for something like a(2:10:5), which is
4287 identical to a(2:7:5). Only relevant for strides not equal
4288 to one. Don't try a division by zero. */
4289 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4290 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4291 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4292 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4296 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4298 if (ar
->end
[i
] == NULL
)
4301 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4303 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4305 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4306 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4308 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4319 if (ar
->type
== AR_FULL
)
4321 if (ar
->as
->rank
== 0)
4322 ar
->type
= AR_ELEMENT
;
4324 /* Make sure array is the same as array(:,:), this way
4325 we don't need to special case all the time. */
4326 ar
->dimen
= ar
->as
->rank
;
4327 for (i
= 0; i
< ar
->dimen
; i
++)
4329 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4331 gcc_assert (ar
->start
[i
] == NULL
);
4332 gcc_assert (ar
->end
[i
] == NULL
);
4333 gcc_assert (ar
->stride
[i
] == NULL
);
4337 /* If the reference type is unknown, figure out what kind it is. */
4339 if (ar
->type
== AR_UNKNOWN
)
4341 ar
->type
= AR_ELEMENT
;
4342 for (i
= 0; i
< ar
->dimen
; i
++)
4343 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4344 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4346 ar
->type
= AR_SECTION
;
4351 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4354 if (ar
->as
->corank
&& ar
->codimen
== 0)
4357 ar
->codimen
= ar
->as
->corank
;
4358 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4359 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4367 resolve_substring (gfc_ref
*ref
)
4369 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4371 if (ref
->u
.ss
.start
!= NULL
)
4373 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4376 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4378 gfc_error ("Substring start index at %L must be of type INTEGER",
4379 &ref
->u
.ss
.start
->where
);
4383 if (ref
->u
.ss
.start
->rank
!= 0)
4385 gfc_error ("Substring start index at %L must be scalar",
4386 &ref
->u
.ss
.start
->where
);
4390 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4391 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4392 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4394 gfc_error ("Substring start index at %L is less than one",
4395 &ref
->u
.ss
.start
->where
);
4400 if (ref
->u
.ss
.end
!= NULL
)
4402 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4405 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4407 gfc_error ("Substring end index at %L must be of type INTEGER",
4408 &ref
->u
.ss
.end
->where
);
4412 if (ref
->u
.ss
.end
->rank
!= 0)
4414 gfc_error ("Substring end index at %L must be scalar",
4415 &ref
->u
.ss
.end
->where
);
4419 if (ref
->u
.ss
.length
!= NULL
4420 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4421 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4422 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4424 gfc_error ("Substring end index at %L exceeds the string length",
4425 &ref
->u
.ss
.start
->where
);
4429 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4430 gfc_integer_kinds
[k
].huge
) == CMP_GT
4431 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4432 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4434 gfc_error ("Substring end index at %L is too large",
4435 &ref
->u
.ss
.end
->where
);
4444 /* This function supplies missing substring charlens. */
4447 gfc_resolve_substring_charlen (gfc_expr
*e
)
4450 gfc_expr
*start
, *end
;
4452 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4453 if (char_ref
->type
== REF_SUBSTRING
)
4459 gcc_assert (char_ref
->next
== NULL
);
4463 if (e
->ts
.u
.cl
->length
)
4464 gfc_free_expr (e
->ts
.u
.cl
->length
);
4465 else if (e
->expr_type
== EXPR_VARIABLE
4466 && e
->symtree
->n
.sym
->attr
.dummy
)
4470 e
->ts
.type
= BT_CHARACTER
;
4471 e
->ts
.kind
= gfc_default_character_kind
;
4474 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4476 if (char_ref
->u
.ss
.start
)
4477 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4479 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4481 if (char_ref
->u
.ss
.end
)
4482 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4483 else if (e
->expr_type
== EXPR_VARIABLE
)
4484 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4490 gfc_free_expr (start
);
4491 gfc_free_expr (end
);
4495 /* Length = (end - start +1). */
4496 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4497 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4498 gfc_get_int_expr (gfc_default_integer_kind
,
4501 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4502 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4504 /* Make sure that the length is simplified. */
4505 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4506 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4510 /* Resolve subtype references. */
4513 resolve_ref (gfc_expr
*expr
)
4515 int current_part_dimension
, n_components
, seen_part_dimension
;
4518 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4519 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4521 find_array_spec (expr
);
4525 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4529 if (!resolve_array_ref (&ref
->u
.ar
))
4537 if (!resolve_substring (ref
))
4542 /* Check constraints on part references. */
4544 current_part_dimension
= 0;
4545 seen_part_dimension
= 0;
4548 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4553 switch (ref
->u
.ar
.type
)
4556 /* Coarray scalar. */
4557 if (ref
->u
.ar
.as
->rank
== 0)
4559 current_part_dimension
= 0;
4564 current_part_dimension
= 1;
4568 current_part_dimension
= 0;
4572 gfc_internal_error ("resolve_ref(): Bad array reference");
4578 if (current_part_dimension
|| seen_part_dimension
)
4581 if (ref
->u
.c
.component
->attr
.pointer
4582 || ref
->u
.c
.component
->attr
.proc_pointer
4583 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4584 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4586 gfc_error ("Component to the right of a part reference "
4587 "with nonzero rank must not have the POINTER "
4588 "attribute at %L", &expr
->where
);
4591 else if (ref
->u
.c
.component
->attr
.allocatable
4592 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4593 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4596 gfc_error ("Component to the right of a part reference "
4597 "with nonzero rank must not have the ALLOCATABLE "
4598 "attribute at %L", &expr
->where
);
4610 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4611 || ref
->next
== NULL
)
4612 && current_part_dimension
4613 && seen_part_dimension
)
4615 gfc_error ("Two or more part references with nonzero rank must "
4616 "not be specified at %L", &expr
->where
);
4620 if (ref
->type
== REF_COMPONENT
)
4622 if (current_part_dimension
)
4623 seen_part_dimension
= 1;
4625 /* reset to make sure */
4626 current_part_dimension
= 0;
4634 /* Given an expression, determine its shape. This is easier than it sounds.
4635 Leaves the shape array NULL if it is not possible to determine the shape. */
4638 expression_shape (gfc_expr
*e
)
4640 mpz_t array
[GFC_MAX_DIMENSIONS
];
4643 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4646 for (i
= 0; i
< e
->rank
; i
++)
4647 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4650 e
->shape
= gfc_get_shape (e
->rank
);
4652 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4657 for (i
--; i
>= 0; i
--)
4658 mpz_clear (array
[i
]);
4662 /* Given a variable expression node, compute the rank of the expression by
4663 examining the base symbol and any reference structures it may have. */
4666 expression_rank (gfc_expr
*e
)
4671 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4672 could lead to serious confusion... */
4673 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4677 if (e
->expr_type
== EXPR_ARRAY
)
4679 /* Constructors can have a rank different from one via RESHAPE(). */
4681 if (e
->symtree
== NULL
)
4687 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4688 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4694 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4696 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4697 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4698 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4700 if (ref
->type
!= REF_ARRAY
)
4703 if (ref
->u
.ar
.type
== AR_FULL
)
4705 rank
= ref
->u
.ar
.as
->rank
;
4709 if (ref
->u
.ar
.type
== AR_SECTION
)
4711 /* Figure out the rank of the section. */
4713 gfc_internal_error ("expression_rank(): Two array specs");
4715 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4716 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4717 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4727 expression_shape (e
);
4731 /* Resolve a variable expression. */
4734 resolve_variable (gfc_expr
*e
)
4741 if (e
->symtree
== NULL
)
4743 sym
= e
->symtree
->n
.sym
;
4745 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4746 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4747 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4749 if (!actual_arg
|| inquiry_argument
)
4751 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4752 "be used as actual argument", sym
->name
, &e
->where
);
4756 /* TS 29113, 407b. */
4757 else if (e
->ts
.type
== BT_ASSUMED
)
4761 gfc_error ("Assumed-type variable %s at %L may only be used "
4762 "as actual argument", sym
->name
, &e
->where
);
4765 else if (inquiry_argument
&& !first_actual_arg
)
4767 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4768 for all inquiry functions in resolve_function; the reason is
4769 that the function-name resolution happens too late in that
4771 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4772 "an inquiry function shall be the first argument",
4773 sym
->name
, &e
->where
);
4777 /* TS 29113, C535b. */
4778 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4779 && CLASS_DATA (sym
)->as
4780 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4781 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4782 && sym
->as
->type
== AS_ASSUMED_RANK
))
4786 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4787 "actual argument", sym
->name
, &e
->where
);
4790 else if (inquiry_argument
&& !first_actual_arg
)
4792 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4793 for all inquiry functions in resolve_function; the reason is
4794 that the function-name resolution happens too late in that
4796 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4797 "to an inquiry function shall be the first argument",
4798 sym
->name
, &e
->where
);
4803 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4804 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4805 && e
->ref
->next
== NULL
))
4807 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4808 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4811 /* TS 29113, 407b. */
4812 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4813 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4814 && e
->ref
->next
== NULL
))
4816 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4817 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4821 /* TS 29113, C535b. */
4822 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4823 && CLASS_DATA (sym
)->as
4824 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4825 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4826 && sym
->as
->type
== AS_ASSUMED_RANK
))
4828 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4829 && e
->ref
->next
== NULL
))
4831 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4832 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4837 /* If this is an associate-name, it may be parsed with an array reference
4838 in error even though the target is scalar. Fail directly in this case.
4839 TODO Understand why class scalar expressions must be excluded. */
4840 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4842 if (sym
->ts
.type
== BT_CLASS
)
4843 gfc_fix_class_refs (e
);
4844 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4848 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4849 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4851 /* On the other hand, the parser may not have known this is an array;
4852 in this case, we have to add a FULL reference. */
4853 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4855 e
->ref
= gfc_get_ref ();
4856 e
->ref
->type
= REF_ARRAY
;
4857 e
->ref
->u
.ar
.type
= AR_FULL
;
4858 e
->ref
->u
.ar
.dimen
= 0;
4861 if (e
->ref
&& !resolve_ref (e
))
4864 if (sym
->attr
.flavor
== FL_PROCEDURE
4865 && (!sym
->attr
.function
4866 || (sym
->attr
.function
&& sym
->result
4867 && sym
->result
->attr
.proc_pointer
4868 && !sym
->result
->attr
.function
)))
4870 e
->ts
.type
= BT_PROCEDURE
;
4871 goto resolve_procedure
;
4874 if (sym
->ts
.type
!= BT_UNKNOWN
)
4875 gfc_variable_attr (e
, &e
->ts
);
4878 /* Must be a simple variable reference. */
4879 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4884 if (check_assumed_size_reference (sym
, e
))
4887 /* Deal with forward references to entries during resolve_code, to
4888 satisfy, at least partially, 12.5.2.5. */
4889 if (gfc_current_ns
->entries
4890 && current_entry_id
== sym
->entry_id
4893 && cs_base
->current
->op
!= EXEC_ENTRY
)
4895 gfc_entry_list
*entry
;
4896 gfc_formal_arglist
*formal
;
4898 bool seen
, saved_specification_expr
;
4900 /* If the symbol is a dummy... */
4901 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4903 entry
= gfc_current_ns
->entries
;
4906 /* ...test if the symbol is a parameter of previous entries. */
4907 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4908 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4910 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4917 /* If it has not been seen as a dummy, this is an error. */
4920 if (specification_expr
)
4921 gfc_error ("Variable '%s', used in a specification expression"
4922 ", is referenced at %L before the ENTRY statement "
4923 "in which it is a parameter",
4924 sym
->name
, &cs_base
->current
->loc
);
4926 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4927 "statement in which it is a parameter",
4928 sym
->name
, &cs_base
->current
->loc
);
4933 /* Now do the same check on the specification expressions. */
4934 saved_specification_expr
= specification_expr
;
4935 specification_expr
= true;
4936 if (sym
->ts
.type
== BT_CHARACTER
4937 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4941 for (n
= 0; n
< sym
->as
->rank
; n
++)
4943 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4945 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4948 specification_expr
= saved_specification_expr
;
4951 /* Update the symbol's entry level. */
4952 sym
->entry_id
= current_entry_id
+ 1;
4955 /* If a symbol has been host_associated mark it. This is used latter,
4956 to identify if aliasing is possible via host association. */
4957 if (sym
->attr
.flavor
== FL_VARIABLE
4958 && gfc_current_ns
->parent
4959 && (gfc_current_ns
->parent
== sym
->ns
4960 || (gfc_current_ns
->parent
->parent
4961 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
4962 sym
->attr
.host_assoc
= 1;
4965 if (t
&& !resolve_procedure_expression (e
))
4968 /* F2008, C617 and C1229. */
4969 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
4970 && gfc_is_coindexed (e
))
4972 gfc_ref
*ref
, *ref2
= NULL
;
4974 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4976 if (ref
->type
== REF_COMPONENT
)
4978 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4982 for ( ; ref
; ref
= ref
->next
)
4983 if (ref
->type
== REF_COMPONENT
)
4986 /* Expression itself is not coindexed object. */
4987 if (ref
&& e
->ts
.type
== BT_CLASS
)
4989 gfc_error ("Polymorphic subobject of coindexed object at %L",
4994 /* Expression itself is coindexed object. */
4998 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
4999 for ( ; c
; c
= c
->next
)
5000 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5002 gfc_error ("Coindexed object with polymorphic allocatable "
5003 "subcomponent at %L", &e
->where
);
5014 /* Checks to see that the correct symbol has been host associated.
5015 The only situation where this arises is that in which a twice
5016 contained function is parsed after the host association is made.
5017 Therefore, on detecting this, change the symbol in the expression
5018 and convert the array reference into an actual arglist if the old
5019 symbol is a variable. */
5021 check_host_association (gfc_expr
*e
)
5023 gfc_symbol
*sym
, *old_sym
;
5027 gfc_actual_arglist
*arg
, *tail
= NULL
;
5028 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5030 /* If the expression is the result of substitution in
5031 interface.c(gfc_extend_expr) because there is no way in
5032 which the host association can be wrong. */
5033 if (e
->symtree
== NULL
5034 || e
->symtree
->n
.sym
== NULL
5035 || e
->user_operator
)
5038 old_sym
= e
->symtree
->n
.sym
;
5040 if (gfc_current_ns
->parent
5041 && old_sym
->ns
!= gfc_current_ns
)
5043 /* Use the 'USE' name so that renamed module symbols are
5044 correctly handled. */
5045 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5047 if (sym
&& old_sym
!= sym
5048 && sym
->ts
.type
== old_sym
->ts
.type
5049 && sym
->attr
.flavor
== FL_PROCEDURE
5050 && sym
->attr
.contained
)
5052 /* Clear the shape, since it might not be valid. */
5053 gfc_free_shape (&e
->shape
, e
->rank
);
5055 /* Give the expression the right symtree! */
5056 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5057 gcc_assert (st
!= NULL
);
5059 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5060 || e
->expr_type
== EXPR_FUNCTION
)
5062 /* Original was function so point to the new symbol, since
5063 the actual argument list is already attached to the
5065 e
->value
.function
.esym
= NULL
;
5070 /* Original was variable so convert array references into
5071 an actual arglist. This does not need any checking now
5072 since resolve_function will take care of it. */
5073 e
->value
.function
.actual
= NULL
;
5074 e
->expr_type
= EXPR_FUNCTION
;
5077 /* Ambiguity will not arise if the array reference is not
5078 the last reference. */
5079 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5080 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5083 gcc_assert (ref
->type
== REF_ARRAY
);
5085 /* Grab the start expressions from the array ref and
5086 copy them into actual arguments. */
5087 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5089 arg
= gfc_get_actual_arglist ();
5090 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5091 if (e
->value
.function
.actual
== NULL
)
5092 tail
= e
->value
.function
.actual
= arg
;
5100 /* Dump the reference list and set the rank. */
5101 gfc_free_ref_list (e
->ref
);
5103 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5106 gfc_resolve_expr (e
);
5110 /* This might have changed! */
5111 return e
->expr_type
== EXPR_FUNCTION
;
5116 gfc_resolve_character_operator (gfc_expr
*e
)
5118 gfc_expr
*op1
= e
->value
.op
.op1
;
5119 gfc_expr
*op2
= e
->value
.op
.op2
;
5120 gfc_expr
*e1
= NULL
;
5121 gfc_expr
*e2
= NULL
;
5123 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5125 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5126 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5127 else if (op1
->expr_type
== EXPR_CONSTANT
)
5128 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5129 op1
->value
.character
.length
);
5131 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5132 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5133 else if (op2
->expr_type
== EXPR_CONSTANT
)
5134 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5135 op2
->value
.character
.length
);
5137 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5147 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5148 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5149 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5150 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5151 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5157 /* Ensure that an character expression has a charlen and, if possible, a
5158 length expression. */
5161 fixup_charlen (gfc_expr
*e
)
5163 /* The cases fall through so that changes in expression type and the need
5164 for multiple fixes are picked up. In all circumstances, a charlen should
5165 be available for the middle end to hang a backend_decl on. */
5166 switch (e
->expr_type
)
5169 gfc_resolve_character_operator (e
);
5172 if (e
->expr_type
== EXPR_ARRAY
)
5173 gfc_resolve_character_array_constructor (e
);
5175 case EXPR_SUBSTRING
:
5176 if (!e
->ts
.u
.cl
&& e
->ref
)
5177 gfc_resolve_substring_charlen (e
);
5181 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5188 /* Update an actual argument to include the passed-object for type-bound
5189 procedures at the right position. */
5191 static gfc_actual_arglist
*
5192 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5195 gcc_assert (argpos
> 0);
5199 gfc_actual_arglist
* result
;
5201 result
= gfc_get_actual_arglist ();
5205 result
->name
= name
;
5211 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5213 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5218 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5221 extract_compcall_passed_object (gfc_expr
* e
)
5225 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5227 if (e
->value
.compcall
.base_object
)
5228 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5231 po
= gfc_get_expr ();
5232 po
->expr_type
= EXPR_VARIABLE
;
5233 po
->symtree
= e
->symtree
;
5234 po
->ref
= gfc_copy_ref (e
->ref
);
5235 po
->where
= e
->where
;
5238 if (!gfc_resolve_expr (po
))
5245 /* Update the arglist of an EXPR_COMPCALL expression to include the
5249 update_compcall_arglist (gfc_expr
* e
)
5252 gfc_typebound_proc
* tbp
;
5254 tbp
= e
->value
.compcall
.tbp
;
5259 po
= extract_compcall_passed_object (e
);
5263 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5269 gcc_assert (tbp
->pass_arg_num
> 0);
5270 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5278 /* Extract the passed object from a PPC call (a copy of it). */
5281 extract_ppc_passed_object (gfc_expr
*e
)
5286 po
= gfc_get_expr ();
5287 po
->expr_type
= EXPR_VARIABLE
;
5288 po
->symtree
= e
->symtree
;
5289 po
->ref
= gfc_copy_ref (e
->ref
);
5290 po
->where
= e
->where
;
5292 /* Remove PPC reference. */
5294 while ((*ref
)->next
)
5295 ref
= &(*ref
)->next
;
5296 gfc_free_ref_list (*ref
);
5299 if (!gfc_resolve_expr (po
))
5306 /* Update the actual arglist of a procedure pointer component to include the
5310 update_ppc_arglist (gfc_expr
* e
)
5314 gfc_typebound_proc
* tb
;
5316 ppc
= gfc_get_proc_ptr_comp (e
);
5324 else if (tb
->nopass
)
5327 po
= extract_ppc_passed_object (e
);
5334 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5339 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5341 gfc_error ("Base object for procedure-pointer component call at %L is of"
5342 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5346 gcc_assert (tb
->pass_arg_num
> 0);
5347 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5355 /* Check that the object a TBP is called on is valid, i.e. it must not be
5356 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5359 check_typebound_baseobject (gfc_expr
* e
)
5362 bool return_value
= false;
5364 base
= extract_compcall_passed_object (e
);
5368 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5370 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5374 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5376 gfc_error ("Base object for type-bound procedure call at %L is of"
5377 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5381 /* F08:C1230. If the procedure called is NOPASS,
5382 the base object must be scalar. */
5383 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5385 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5386 " be scalar", &e
->where
);
5390 return_value
= true;
5393 gfc_free_expr (base
);
5394 return return_value
;
5398 /* Resolve a call to a type-bound procedure, either function or subroutine,
5399 statically from the data in an EXPR_COMPCALL expression. The adapted
5400 arglist and the target-procedure symtree are returned. */
5403 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5404 gfc_actual_arglist
** actual
)
5406 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5407 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5409 /* Update the actual arglist for PASS. */
5410 if (!update_compcall_arglist (e
))
5413 *actual
= e
->value
.compcall
.actual
;
5414 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5416 gfc_free_ref_list (e
->ref
);
5418 e
->value
.compcall
.actual
= NULL
;
5420 /* If we find a deferred typebound procedure, check for derived types
5421 that an overriding typebound procedure has not been missed. */
5422 if (e
->value
.compcall
.name
5423 && !e
->value
.compcall
.tbp
->non_overridable
5424 && e
->value
.compcall
.base_object
5425 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5428 gfc_symbol
*derived
;
5430 /* Use the derived type of the base_object. */
5431 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5434 /* If necessary, go through the inheritance chain. */
5435 while (!st
&& derived
)
5437 /* Look for the typebound procedure 'name'. */
5438 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5439 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5440 e
->value
.compcall
.name
);
5442 derived
= gfc_get_derived_super_type (derived
);
5445 /* Now find the specific name in the derived type namespace. */
5446 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5447 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5448 derived
->ns
, 1, &st
);
5456 /* Get the ultimate declared type from an expression. In addition,
5457 return the last class/derived type reference and the copy of the
5458 reference list. If check_types is set true, derived types are
5459 identified as well as class references. */
5461 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5462 gfc_expr
*e
, bool check_types
)
5464 gfc_symbol
*declared
;
5471 *new_ref
= gfc_copy_ref (e
->ref
);
5473 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5475 if (ref
->type
!= REF_COMPONENT
)
5478 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5479 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5480 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5482 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5488 if (declared
== NULL
)
5489 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5495 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5496 which of the specific bindings (if any) matches the arglist and transform
5497 the expression into a call of that binding. */
5500 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5502 gfc_typebound_proc
* genproc
;
5503 const char* genname
;
5505 gfc_symbol
*derived
;
5507 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5508 genname
= e
->value
.compcall
.name
;
5509 genproc
= e
->value
.compcall
.tbp
;
5511 if (!genproc
->is_generic
)
5514 /* Try the bindings on this type and in the inheritance hierarchy. */
5515 for (; genproc
; genproc
= genproc
->overridden
)
5519 gcc_assert (genproc
->is_generic
);
5520 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5523 gfc_actual_arglist
* args
;
5526 gcc_assert (g
->specific
);
5528 if (g
->specific
->error
)
5531 target
= g
->specific
->u
.specific
->n
.sym
;
5533 /* Get the right arglist by handling PASS/NOPASS. */
5534 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5535 if (!g
->specific
->nopass
)
5538 po
= extract_compcall_passed_object (e
);
5541 gfc_free_actual_arglist (args
);
5545 gcc_assert (g
->specific
->pass_arg_num
> 0);
5546 gcc_assert (!g
->specific
->error
);
5547 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5548 g
->specific
->pass_arg
);
5550 resolve_actual_arglist (args
, target
->attr
.proc
,
5551 is_external_proc (target
)
5552 && gfc_sym_get_dummy_args (target
) == NULL
);
5554 /* Check if this arglist matches the formal. */
5555 matches
= gfc_arglist_matches_symbol (&args
, target
);
5557 /* Clean up and break out of the loop if we've found it. */
5558 gfc_free_actual_arglist (args
);
5561 e
->value
.compcall
.tbp
= g
->specific
;
5562 genname
= g
->specific_st
->name
;
5563 /* Pass along the name for CLASS methods, where the vtab
5564 procedure pointer component has to be referenced. */
5572 /* Nothing matching found! */
5573 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5574 " '%s' at %L", genname
, &e
->where
);
5578 /* Make sure that we have the right specific instance for the name. */
5579 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5581 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5583 e
->value
.compcall
.tbp
= st
->n
.tb
;
5589 /* Resolve a call to a type-bound subroutine. */
5592 resolve_typebound_call (gfc_code
* c
, const char **name
)
5594 gfc_actual_arglist
* newactual
;
5595 gfc_symtree
* target
;
5597 /* Check that's really a SUBROUTINE. */
5598 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5600 gfc_error ("'%s' at %L should be a SUBROUTINE",
5601 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5605 if (!check_typebound_baseobject (c
->expr1
))
5608 /* Pass along the name for CLASS methods, where the vtab
5609 procedure pointer component has to be referenced. */
5611 *name
= c
->expr1
->value
.compcall
.name
;
5613 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5616 /* Transform into an ordinary EXEC_CALL for now. */
5618 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5621 c
->ext
.actual
= newactual
;
5622 c
->symtree
= target
;
5623 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5625 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5627 gfc_free_expr (c
->expr1
);
5628 c
->expr1
= gfc_get_expr ();
5629 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5630 c
->expr1
->symtree
= target
;
5631 c
->expr1
->where
= c
->loc
;
5633 return resolve_call (c
);
5637 /* Resolve a component-call expression. */
5639 resolve_compcall (gfc_expr
* e
, const char **name
)
5641 gfc_actual_arglist
* newactual
;
5642 gfc_symtree
* target
;
5644 /* Check that's really a FUNCTION. */
5645 if (!e
->value
.compcall
.tbp
->function
)
5647 gfc_error ("'%s' at %L should be a FUNCTION",
5648 e
->value
.compcall
.name
, &e
->where
);
5652 /* These must not be assign-calls! */
5653 gcc_assert (!e
->value
.compcall
.assign
);
5655 if (!check_typebound_baseobject (e
))
5658 /* Pass along the name for CLASS methods, where the vtab
5659 procedure pointer component has to be referenced. */
5661 *name
= e
->value
.compcall
.name
;
5663 if (!resolve_typebound_generic_call (e
, name
))
5665 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5667 /* Take the rank from the function's symbol. */
5668 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5669 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5671 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5672 arglist to the TBP's binding target. */
5674 if (!resolve_typebound_static (e
, &target
, &newactual
))
5677 e
->value
.function
.actual
= newactual
;
5678 e
->value
.function
.name
= NULL
;
5679 e
->value
.function
.esym
= target
->n
.sym
;
5680 e
->value
.function
.isym
= NULL
;
5681 e
->symtree
= target
;
5682 e
->ts
= target
->n
.sym
->ts
;
5683 e
->expr_type
= EXPR_FUNCTION
;
5685 /* Resolution is not necessary if this is a class subroutine; this
5686 function only has to identify the specific proc. Resolution of
5687 the call will be done next in resolve_typebound_call. */
5688 return gfc_resolve_expr (e
);
5692 static bool resolve_fl_derived (gfc_symbol
*sym
);
5695 /* Resolve a typebound function, or 'method'. First separate all
5696 the non-CLASS references by calling resolve_compcall directly. */
5699 resolve_typebound_function (gfc_expr
* e
)
5701 gfc_symbol
*declared
;
5713 /* Deal with typebound operators for CLASS objects. */
5714 expr
= e
->value
.compcall
.base_object
;
5715 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5716 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5718 /* If the base_object is not a variable, the corresponding actual
5719 argument expression must be stored in e->base_expression so
5720 that the corresponding tree temporary can be used as the base
5721 object in gfc_conv_procedure_call. */
5722 if (expr
->expr_type
!= EXPR_VARIABLE
)
5724 gfc_actual_arglist
*args
;
5726 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5728 if (expr
== args
->expr
)
5733 /* Since the typebound operators are generic, we have to ensure
5734 that any delays in resolution are corrected and that the vtab
5737 declared
= ts
.u
.derived
;
5738 c
= gfc_find_component (declared
, "_vptr", true, true);
5739 if (c
->ts
.u
.derived
== NULL
)
5740 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5742 if (!resolve_compcall (e
, &name
))
5745 /* Use the generic name if it is there. */
5746 name
= name
? name
: e
->value
.function
.esym
->name
;
5747 e
->symtree
= expr
->symtree
;
5748 e
->ref
= gfc_copy_ref (expr
->ref
);
5749 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5751 /* Trim away the extraneous references that emerge from nested
5752 use of interface.c (extend_expr). */
5753 if (class_ref
&& class_ref
->next
)
5755 gfc_free_ref_list (class_ref
->next
);
5756 class_ref
->next
= NULL
;
5758 else if (e
->ref
&& !class_ref
)
5760 gfc_free_ref_list (e
->ref
);
5764 gfc_add_vptr_component (e
);
5765 gfc_add_component_ref (e
, name
);
5766 e
->value
.function
.esym
= NULL
;
5767 if (expr
->expr_type
!= EXPR_VARIABLE
)
5768 e
->base_expr
= expr
;
5773 return resolve_compcall (e
, NULL
);
5775 if (!resolve_ref (e
))
5778 /* Get the CLASS declared type. */
5779 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5781 if (!resolve_fl_derived (declared
))
5784 /* Weed out cases of the ultimate component being a derived type. */
5785 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5786 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5788 gfc_free_ref_list (new_ref
);
5789 return resolve_compcall (e
, NULL
);
5792 c
= gfc_find_component (declared
, "_data", true, true);
5793 declared
= c
->ts
.u
.derived
;
5795 /* Treat the call as if it is a typebound procedure, in order to roll
5796 out the correct name for the specific function. */
5797 if (!resolve_compcall (e
, &name
))
5799 gfc_free_ref_list (new_ref
);
5806 /* Convert the expression to a procedure pointer component call. */
5807 e
->value
.function
.esym
= NULL
;
5813 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5814 gfc_add_vptr_component (e
);
5815 gfc_add_component_ref (e
, name
);
5817 /* Recover the typespec for the expression. This is really only
5818 necessary for generic procedures, where the additional call
5819 to gfc_add_component_ref seems to throw the collection of the
5820 correct typespec. */
5824 gfc_free_ref_list (new_ref
);
5829 /* Resolve a typebound subroutine, or 'method'. First separate all
5830 the non-CLASS references by calling resolve_typebound_call
5834 resolve_typebound_subroutine (gfc_code
*code
)
5836 gfc_symbol
*declared
;
5846 st
= code
->expr1
->symtree
;
5848 /* Deal with typebound operators for CLASS objects. */
5849 expr
= code
->expr1
->value
.compcall
.base_object
;
5850 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5851 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5853 /* If the base_object is not a variable, the corresponding actual
5854 argument expression must be stored in e->base_expression so
5855 that the corresponding tree temporary can be used as the base
5856 object in gfc_conv_procedure_call. */
5857 if (expr
->expr_type
!= EXPR_VARIABLE
)
5859 gfc_actual_arglist
*args
;
5861 args
= code
->expr1
->value
.function
.actual
;
5862 for (; args
; args
= args
->next
)
5863 if (expr
== args
->expr
)
5867 /* Since the typebound operators are generic, we have to ensure
5868 that any delays in resolution are corrected and that the vtab
5870 declared
= expr
->ts
.u
.derived
;
5871 c
= gfc_find_component (declared
, "_vptr", true, true);
5872 if (c
->ts
.u
.derived
== NULL
)
5873 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5875 if (!resolve_typebound_call (code
, &name
))
5878 /* Use the generic name if it is there. */
5879 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5880 code
->expr1
->symtree
= expr
->symtree
;
5881 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5883 /* Trim away the extraneous references that emerge from nested
5884 use of interface.c (extend_expr). */
5885 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5886 if (class_ref
&& class_ref
->next
)
5888 gfc_free_ref_list (class_ref
->next
);
5889 class_ref
->next
= NULL
;
5891 else if (code
->expr1
->ref
&& !class_ref
)
5893 gfc_free_ref_list (code
->expr1
->ref
);
5894 code
->expr1
->ref
= NULL
;
5897 /* Now use the procedure in the vtable. */
5898 gfc_add_vptr_component (code
->expr1
);
5899 gfc_add_component_ref (code
->expr1
, name
);
5900 code
->expr1
->value
.function
.esym
= NULL
;
5901 if (expr
->expr_type
!= EXPR_VARIABLE
)
5902 code
->expr1
->base_expr
= expr
;
5907 return resolve_typebound_call (code
, NULL
);
5909 if (!resolve_ref (code
->expr1
))
5912 /* Get the CLASS declared type. */
5913 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5915 /* Weed out cases of the ultimate component being a derived type. */
5916 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5917 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5919 gfc_free_ref_list (new_ref
);
5920 return resolve_typebound_call (code
, NULL
);
5923 if (!resolve_typebound_call (code
, &name
))
5925 gfc_free_ref_list (new_ref
);
5928 ts
= code
->expr1
->ts
;
5932 /* Convert the expression to a procedure pointer component call. */
5933 code
->expr1
->value
.function
.esym
= NULL
;
5934 code
->expr1
->symtree
= st
;
5937 code
->expr1
->ref
= new_ref
;
5939 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5940 gfc_add_vptr_component (code
->expr1
);
5941 gfc_add_component_ref (code
->expr1
, name
);
5943 /* Recover the typespec for the expression. This is really only
5944 necessary for generic procedures, where the additional call
5945 to gfc_add_component_ref seems to throw the collection of the
5946 correct typespec. */
5947 code
->expr1
->ts
= ts
;
5950 gfc_free_ref_list (new_ref
);
5956 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5959 resolve_ppc_call (gfc_code
* c
)
5961 gfc_component
*comp
;
5963 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
5964 gcc_assert (comp
!= NULL
);
5966 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5967 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5969 if (!comp
->attr
.subroutine
)
5970 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5972 if (!resolve_ref (c
->expr1
))
5975 if (!update_ppc_arglist (c
->expr1
))
5978 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5980 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5981 !(comp
->ts
.interface
5982 && comp
->ts
.interface
->formal
)))
5985 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5991 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5994 resolve_expr_ppc (gfc_expr
* e
)
5996 gfc_component
*comp
;
5998 comp
= gfc_get_proc_ptr_comp (e
);
5999 gcc_assert (comp
!= NULL
);
6001 /* Convert to EXPR_FUNCTION. */
6002 e
->expr_type
= EXPR_FUNCTION
;
6003 e
->value
.function
.isym
= NULL
;
6004 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6006 if (comp
->as
!= NULL
)
6007 e
->rank
= comp
->as
->rank
;
6009 if (!comp
->attr
.function
)
6010 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6012 if (!resolve_ref (e
))
6015 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6016 !(comp
->ts
.interface
6017 && comp
->ts
.interface
->formal
)))
6020 if (!update_ppc_arglist (e
))
6023 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6030 gfc_is_expandable_expr (gfc_expr
*e
)
6032 gfc_constructor
*con
;
6034 if (e
->expr_type
== EXPR_ARRAY
)
6036 /* Traverse the constructor looking for variables that are flavor
6037 parameter. Parameters must be expanded since they are fully used at
6039 con
= gfc_constructor_first (e
->value
.constructor
);
6040 for (; con
; con
= gfc_constructor_next (con
))
6042 if (con
->expr
->expr_type
== EXPR_VARIABLE
6043 && con
->expr
->symtree
6044 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6045 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6047 if (con
->expr
->expr_type
== EXPR_ARRAY
6048 && gfc_is_expandable_expr (con
->expr
))
6056 /* Resolve an expression. That is, make sure that types of operands agree
6057 with their operators, intrinsic operators are converted to function calls
6058 for overloaded types and unresolved function references are resolved. */
6061 gfc_resolve_expr (gfc_expr
*e
)
6064 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6069 /* inquiry_argument only applies to variables. */
6070 inquiry_save
= inquiry_argument
;
6071 actual_arg_save
= actual_arg
;
6072 first_actual_arg_save
= first_actual_arg
;
6074 if (e
->expr_type
!= EXPR_VARIABLE
)
6076 inquiry_argument
= false;
6078 first_actual_arg
= false;
6081 switch (e
->expr_type
)
6084 t
= resolve_operator (e
);
6090 if (check_host_association (e
))
6091 t
= resolve_function (e
);
6094 t
= resolve_variable (e
);
6096 expression_rank (e
);
6099 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6100 && e
->ref
->type
!= REF_SUBSTRING
)
6101 gfc_resolve_substring_charlen (e
);
6106 t
= resolve_typebound_function (e
);
6109 case EXPR_SUBSTRING
:
6110 t
= resolve_ref (e
);
6119 t
= resolve_expr_ppc (e
);
6124 if (!resolve_ref (e
))
6127 t
= gfc_resolve_array_constructor (e
);
6128 /* Also try to expand a constructor. */
6131 expression_rank (e
);
6132 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6133 gfc_expand_constructor (e
, false);
6136 /* This provides the opportunity for the length of constructors with
6137 character valued function elements to propagate the string length
6138 to the expression. */
6139 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6141 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6142 here rather then add a duplicate test for it above. */
6143 gfc_expand_constructor (e
, false);
6144 t
= gfc_resolve_character_array_constructor (e
);
6149 case EXPR_STRUCTURE
:
6150 t
= resolve_ref (e
);
6154 t
= resolve_structure_cons (e
, 0);
6158 t
= gfc_simplify_expr (e
, 0);
6162 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6165 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6168 inquiry_argument
= inquiry_save
;
6169 actual_arg
= actual_arg_save
;
6170 first_actual_arg
= first_actual_arg_save
;
6176 /* Resolve an expression from an iterator. They must be scalar and have
6177 INTEGER or (optionally) REAL type. */
6180 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6181 const char *name_msgid
)
6183 if (!gfc_resolve_expr (expr
))
6186 if (expr
->rank
!= 0)
6188 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6192 if (expr
->ts
.type
!= BT_INTEGER
)
6194 if (expr
->ts
.type
== BT_REAL
)
6197 return gfc_notify_std (GFC_STD_F95_DEL
,
6198 "%s at %L must be integer",
6199 _(name_msgid
), &expr
->where
);
6202 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6209 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6217 /* Resolve the expressions in an iterator structure. If REAL_OK is
6218 false allow only INTEGER type iterators, otherwise allow REAL types.
6219 Set own_scope to true for ac-implied-do and data-implied-do as those
6220 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6223 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6225 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6228 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6229 _("iterator variable")))
6232 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6233 "Start expression in DO loop"))
6236 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6237 "End expression in DO loop"))
6240 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6241 "Step expression in DO loop"))
6244 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6246 if ((iter
->step
->ts
.type
== BT_INTEGER
6247 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6248 || (iter
->step
->ts
.type
== BT_REAL
6249 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6251 gfc_error ("Step expression in DO loop at %L cannot be zero",
6252 &iter
->step
->where
);
6257 /* Convert start, end, and step to the same type as var. */
6258 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6259 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6260 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6262 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6263 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6264 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6266 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6267 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6268 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6270 if (iter
->start
->expr_type
== EXPR_CONSTANT
6271 && iter
->end
->expr_type
== EXPR_CONSTANT
6272 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6275 if (iter
->start
->ts
.type
== BT_INTEGER
)
6277 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6278 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6282 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6283 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6285 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6286 gfc_warning ("DO loop at %L will be executed zero times",
6287 &iter
->step
->where
);
6294 /* Traversal function for find_forall_index. f == 2 signals that
6295 that variable itself is not to be checked - only the references. */
6298 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6300 if (expr
->expr_type
!= EXPR_VARIABLE
)
6303 /* A scalar assignment */
6304 if (!expr
->ref
|| *f
== 1)
6306 if (expr
->symtree
->n
.sym
== sym
)
6318 /* Check whether the FORALL index appears in the expression or not.
6319 Returns true if SYM is found in EXPR. */
6322 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6324 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6331 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6332 to be a scalar INTEGER variable. The subscripts and stride are scalar
6333 INTEGERs, and if stride is a constant it must be nonzero.
6334 Furthermore "A subscript or stride in a forall-triplet-spec shall
6335 not contain a reference to any index-name in the
6336 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6339 resolve_forall_iterators (gfc_forall_iterator
*it
)
6341 gfc_forall_iterator
*iter
, *iter2
;
6343 for (iter
= it
; iter
; iter
= iter
->next
)
6345 if (gfc_resolve_expr (iter
->var
)
6346 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6347 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6350 if (gfc_resolve_expr (iter
->start
)
6351 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6352 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6353 &iter
->start
->where
);
6354 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6355 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6357 if (gfc_resolve_expr (iter
->end
)
6358 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6359 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6361 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6362 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6364 if (gfc_resolve_expr (iter
->stride
))
6366 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6367 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6368 &iter
->stride
->where
, "INTEGER");
6370 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6371 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6372 gfc_error ("FORALL stride expression at %L cannot be zero",
6373 &iter
->stride
->where
);
6375 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6376 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6379 for (iter
= it
; iter
; iter
= iter
->next
)
6380 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6382 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6383 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6384 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6385 gfc_error ("FORALL index '%s' may not appear in triplet "
6386 "specification at %L", iter
->var
->symtree
->name
,
6387 &iter2
->start
->where
);
6392 /* Given a pointer to a symbol that is a derived type, see if it's
6393 inaccessible, i.e. if it's defined in another module and the components are
6394 PRIVATE. The search is recursive if necessary. Returns zero if no
6395 inaccessible components are found, nonzero otherwise. */
6398 derived_inaccessible (gfc_symbol
*sym
)
6402 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6405 for (c
= sym
->components
; c
; c
= c
->next
)
6407 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6415 /* Resolve the argument of a deallocate expression. The expression must be
6416 a pointer or a full array. */
6419 resolve_deallocate_expr (gfc_expr
*e
)
6421 symbol_attribute attr
;
6422 int allocatable
, pointer
;
6428 if (!gfc_resolve_expr (e
))
6431 if (e
->expr_type
!= EXPR_VARIABLE
)
6434 sym
= e
->symtree
->n
.sym
;
6435 unlimited
= UNLIMITED_POLY(sym
);
6437 if (sym
->ts
.type
== BT_CLASS
)
6439 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6440 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6444 allocatable
= sym
->attr
.allocatable
;
6445 pointer
= sym
->attr
.pointer
;
6447 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6452 if (ref
->u
.ar
.type
!= AR_FULL
6453 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6454 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6459 c
= ref
->u
.c
.component
;
6460 if (c
->ts
.type
== BT_CLASS
)
6462 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6463 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6467 allocatable
= c
->attr
.allocatable
;
6468 pointer
= c
->attr
.pointer
;
6478 attr
= gfc_expr_attr (e
);
6480 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6483 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6489 if (gfc_is_coindexed (e
))
6491 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6496 && !gfc_check_vardef_context (e
, true, true, false,
6497 _("DEALLOCATE object")))
6499 if (!gfc_check_vardef_context (e
, false, true, false,
6500 _("DEALLOCATE object")))
6507 /* Returns true if the expression e contains a reference to the symbol sym. */
6509 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6511 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6518 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6520 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6524 /* Given the expression node e for an allocatable/pointer of derived type to be
6525 allocated, get the expression node to be initialized afterwards (needed for
6526 derived types with default initializers, and derived types with allocatable
6527 components that need nullification.) */
6530 gfc_expr_to_initialize (gfc_expr
*e
)
6536 result
= gfc_copy_expr (e
);
6538 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6539 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6540 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6542 ref
->u
.ar
.type
= AR_FULL
;
6544 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6545 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6550 gfc_free_shape (&result
->shape
, result
->rank
);
6552 /* Recalculate rank, shape, etc. */
6553 gfc_resolve_expr (result
);
6558 /* If the last ref of an expression is an array ref, return a copy of the
6559 expression with that one removed. Otherwise, a copy of the original
6560 expression. This is used for allocate-expressions and pointer assignment
6561 LHS, where there may be an array specification that needs to be stripped
6562 off when using gfc_check_vardef_context. */
6565 remove_last_array_ref (gfc_expr
* e
)
6570 e2
= gfc_copy_expr (e
);
6571 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6572 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6574 gfc_free_ref_list (*r
);
6583 /* Used in resolve_allocate_expr to check that a allocation-object and
6584 a source-expr are conformable. This does not catch all possible
6585 cases; in particular a runtime checking is needed. */
6588 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6591 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6593 /* First compare rank. */
6594 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6596 gfc_error ("Source-expr at %L must be scalar or have the "
6597 "same rank as the allocate-object at %L",
6598 &e1
->where
, &e2
->where
);
6609 for (i
= 0; i
< e1
->rank
; i
++)
6611 if (tail
->u
.ar
.start
[i
] == NULL
)
6614 if (tail
->u
.ar
.end
[i
])
6616 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6617 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6618 mpz_add_ui (s
, s
, 1);
6622 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6625 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6627 gfc_error ("Source-expr at %L and allocate-object at %L must "
6628 "have the same shape", &e1
->where
, &e2
->where
);
6641 /* Resolve the expression in an ALLOCATE statement, doing the additional
6642 checks to see whether the expression is OK or not. The expression must
6643 have a trailing array reference that gives the size of the array. */
6646 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6648 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6652 symbol_attribute attr
;
6653 gfc_ref
*ref
, *ref2
;
6656 gfc_symbol
*sym
= NULL
;
6661 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6662 checking of coarrays. */
6663 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6664 if (ref
->next
== NULL
)
6667 if (ref
&& ref
->type
== REF_ARRAY
)
6668 ref
->u
.ar
.in_allocate
= true;
6670 if (!gfc_resolve_expr (e
))
6673 /* Make sure the expression is allocatable or a pointer. If it is
6674 pointer, the next-to-last reference must be a pointer. */
6678 sym
= e
->symtree
->n
.sym
;
6680 /* Check whether ultimate component is abstract and CLASS. */
6683 /* Is the allocate-object unlimited polymorphic? */
6684 unlimited
= UNLIMITED_POLY(e
);
6686 if (e
->expr_type
!= EXPR_VARIABLE
)
6689 attr
= gfc_expr_attr (e
);
6690 pointer
= attr
.pointer
;
6691 dimension
= attr
.dimension
;
6692 codimension
= attr
.codimension
;
6696 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6698 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6699 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6700 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6701 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6702 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6706 allocatable
= sym
->attr
.allocatable
;
6707 pointer
= sym
->attr
.pointer
;
6708 dimension
= sym
->attr
.dimension
;
6709 codimension
= sym
->attr
.codimension
;
6714 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6719 if (ref
->u
.ar
.codimen
> 0)
6722 for (n
= ref
->u
.ar
.dimen
;
6723 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6724 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6731 if (ref
->next
!= NULL
)
6739 gfc_error ("Coindexed allocatable object at %L",
6744 c
= ref
->u
.c
.component
;
6745 if (c
->ts
.type
== BT_CLASS
)
6747 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6748 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6749 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6750 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6751 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6755 allocatable
= c
->attr
.allocatable
;
6756 pointer
= c
->attr
.pointer
;
6757 dimension
= c
->attr
.dimension
;
6758 codimension
= c
->attr
.codimension
;
6759 is_abstract
= c
->attr
.abstract
;
6771 /* Check for F08:C628. */
6772 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6774 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6779 /* Some checks for the SOURCE tag. */
6782 /* Check F03:C631. */
6783 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6785 gfc_error ("Type of entity at %L is type incompatible with "
6786 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6790 /* Check F03:C632 and restriction following Note 6.18. */
6791 if (code
->expr3
->rank
> 0 && !unlimited
6792 && !conformable_arrays (code
->expr3
, e
))
6795 /* Check F03:C633. */
6796 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6798 gfc_error ("The allocate-object at %L and the source-expr at %L "
6799 "shall have the same kind type parameter",
6800 &e
->where
, &code
->expr3
->where
);
6804 /* Check F2008, C642. */
6805 if (code
->expr3
->ts
.type
== BT_DERIVED
6806 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6807 || (code
->expr3
->ts
.u
.derived
->from_intmod
6808 == INTMOD_ISO_FORTRAN_ENV
6809 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6810 == ISOFORTRAN_LOCK_TYPE
)))
6812 gfc_error ("The source-expr at %L shall neither be of type "
6813 "LOCK_TYPE nor have a LOCK_TYPE component if "
6814 "allocate-object at %L is a coarray",
6815 &code
->expr3
->where
, &e
->where
);
6820 /* Check F08:C629. */
6821 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6824 gcc_assert (e
->ts
.type
== BT_CLASS
);
6825 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6826 "type-spec or source-expr", sym
->name
, &e
->where
);
6830 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6832 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6833 code
->ext
.alloc
.ts
.u
.cl
->length
);
6834 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6836 gfc_error ("Allocating %s at %L with type-spec requires the same "
6837 "character-length parameter as in the declaration",
6838 sym
->name
, &e
->where
);
6843 /* In the variable definition context checks, gfc_expr_attr is used
6844 on the expression. This is fooled by the array specification
6845 present in e, thus we have to eliminate that one temporarily. */
6846 e2
= remove_last_array_ref (e
);
6849 t
= gfc_check_vardef_context (e2
, true, true, false,
6850 _("ALLOCATE object"));
6852 t
= gfc_check_vardef_context (e2
, false, true, false,
6853 _("ALLOCATE object"));
6858 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6859 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6861 /* For class arrays, the initialization with SOURCE is done
6862 using _copy and trans_call. It is convenient to exploit that
6863 when the allocated type is different from the declared type but
6864 no SOURCE exists by setting expr3. */
6865 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6867 else if (!code
->expr3
)
6869 /* Set up default initializer if needed. */
6873 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6874 ts
= code
->ext
.alloc
.ts
;
6878 if (ts
.type
== BT_CLASS
)
6879 ts
= ts
.u
.derived
->components
->ts
;
6881 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6883 gfc_code
*init_st
= gfc_get_code ();
6884 init_st
->loc
= code
->loc
;
6885 init_st
->op
= EXEC_INIT_ASSIGN
;
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 ();
8024 new_st
->op
= code
->op
;
8025 new_st
->expr1
= code
->expr1
;
8026 new_st
->expr2
= code
->expr2
;
8027 new_st
->block
= code
->block
;
8028 code
->expr1
= code
->expr2
= NULL
;
8033 ns
->code
->next
= new_st
;
8035 code
->op
= EXEC_SELECT
;
8037 gfc_add_vptr_component (code
->expr1
);
8038 gfc_add_hash_component (code
->expr1
);
8040 /* Loop over TYPE IS / CLASS IS cases. */
8041 for (body
= code
->block
; body
; body
= body
->block
)
8043 c
= body
->ext
.block
.case_list
;
8045 if (c
->ts
.type
== BT_DERIVED
)
8046 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8047 c
->ts
.u
.derived
->hash_value
);
8048 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8053 ivtab
= gfc_find_intrinsic_vtab (&c
->ts
);
8054 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8055 e
= CLASS_DATA (ivtab
)->initializer
;
8056 c
->low
= c
->high
= gfc_copy_expr (e
);
8059 else if (c
->ts
.type
== BT_UNKNOWN
)
8062 /* Associate temporary to selector. This should only be done
8063 when this case is actually true, so build a new ASSOCIATE
8064 that does precisely this here (instead of using the
8067 if (c
->ts
.type
== BT_CLASS
)
8068 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8069 else if (c
->ts
.type
== BT_DERIVED
)
8070 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8071 else if (c
->ts
.type
== BT_CHARACTER
)
8073 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8074 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8075 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8076 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8077 charlen
, c
->ts
.kind
);
8080 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8083 st
= gfc_find_symtree (ns
->sym_root
, name
);
8084 gcc_assert (st
->n
.sym
->assoc
);
8085 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8086 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8087 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8088 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8090 new_st
= gfc_get_code ();
8091 new_st
->op
= EXEC_BLOCK
;
8092 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8093 new_st
->ext
.block
.ns
->code
= body
->next
;
8094 body
->next
= new_st
;
8096 /* Chain in the new list only if it is marked as dangling. Otherwise
8097 there is a CASE label overlap and this is already used. Just ignore,
8098 the error is diagnosed elsewhere. */
8099 if (st
->n
.sym
->assoc
->dangling
)
8101 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8102 st
->n
.sym
->assoc
->dangling
= 0;
8105 resolve_assoc_var (st
->n
.sym
, false);
8108 /* Take out CLASS IS cases for separate treatment. */
8110 while (body
&& body
->block
)
8112 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8114 /* Add to class_is list. */
8115 if (class_is
== NULL
)
8117 class_is
= body
->block
;
8122 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8123 tail
->block
= body
->block
;
8126 /* Remove from EXEC_SELECT list. */
8127 body
->block
= body
->block
->block
;
8140 /* Add a default case to hold the CLASS IS cases. */
8141 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8142 tail
->block
= gfc_get_code ();
8144 tail
->op
= EXEC_SELECT_TYPE
;
8145 tail
->ext
.block
.case_list
= gfc_get_case ();
8146 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8148 default_case
= tail
;
8151 /* More than one CLASS IS block? */
8152 if (class_is
->block
)
8156 /* Sort CLASS IS blocks by extension level. */
8160 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8163 /* F03:C817 (check for doubles). */
8164 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8165 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8167 gfc_error ("Double CLASS IS block in SELECT TYPE "
8169 &c2
->ext
.block
.case_list
->where
);
8172 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8173 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8176 (*c1
)->block
= c2
->block
;
8186 /* Generate IF chain. */
8187 if_st
= gfc_get_code ();
8188 if_st
->op
= EXEC_IF
;
8190 for (body
= class_is
; body
; body
= body
->block
)
8192 new_st
->block
= gfc_get_code ();
8193 new_st
= new_st
->block
;
8194 new_st
->op
= EXEC_IF
;
8195 /* Set up IF condition: Call _gfortran_is_extension_of. */
8196 new_st
->expr1
= gfc_get_expr ();
8197 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8198 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8199 new_st
->expr1
->ts
.kind
= 4;
8200 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8201 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8202 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8203 /* Set up arguments. */
8204 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8205 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8206 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8207 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8208 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8209 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8210 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8211 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8212 new_st
->next
= body
->next
;
8214 if (default_case
->next
)
8216 new_st
->block
= gfc_get_code ();
8217 new_st
= new_st
->block
;
8218 new_st
->op
= EXEC_IF
;
8219 new_st
->next
= default_case
->next
;
8222 /* Replace CLASS DEFAULT code by the IF chain. */
8223 default_case
->next
= if_st
;
8226 /* Resolve the internal code. This can not be done earlier because
8227 it requires that the sym->assoc of selectors is set already. */
8228 gfc_current_ns
= ns
;
8229 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8230 gfc_current_ns
= old_ns
;
8232 resolve_select (code
, true);
8236 /* Resolve a transfer statement. This is making sure that:
8237 -- a derived type being transferred has only non-pointer components
8238 -- a derived type being transferred doesn't have private components, unless
8239 it's being transferred from the module where the type was defined
8240 -- we're not trying to transfer a whole assumed size array. */
8243 resolve_transfer (gfc_code
*code
)
8252 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8253 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8254 exp
= exp
->value
.op
.op1
;
8256 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8258 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8259 "MOLD=", &exp
->where
);
8263 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8264 && exp
->expr_type
!= EXPR_FUNCTION
))
8267 /* If we are reading, the variable will be changed. Note that
8268 code->ext.dt may be NULL if the TRANSFER is related to
8269 an INQUIRE statement -- but in this case, we are not reading, either. */
8270 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8271 && !gfc_check_vardef_context (exp
, false, false, false,
8275 sym
= exp
->symtree
->n
.sym
;
8278 /* Go to actual component transferred. */
8279 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8280 if (ref
->type
== REF_COMPONENT
)
8281 ts
= &ref
->u
.c
.component
->ts
;
8283 if (ts
->type
== BT_CLASS
)
8285 /* FIXME: Test for defined input/output. */
8286 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8287 "it is processed by a defined input/output procedure",
8292 if (ts
->type
== BT_DERIVED
)
8294 /* Check that transferred derived type doesn't contain POINTER
8296 if (ts
->u
.derived
->attr
.pointer_comp
)
8298 gfc_error ("Data transfer element at %L cannot have POINTER "
8299 "components unless it is processed by a defined "
8300 "input/output procedure", &code
->loc
);
8305 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8307 gfc_error ("Data transfer element at %L cannot have "
8308 "procedure pointer components", &code
->loc
);
8312 if (ts
->u
.derived
->attr
.alloc_comp
)
8314 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8315 "components unless it is processed by a defined "
8316 "input/output procedure", &code
->loc
);
8320 /* C_PTR and C_FUNPTR have private components which means they can not
8321 be printed. However, if -std=gnu and not -pedantic, allow
8322 the component to be printed to help debugging. */
8323 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8325 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8326 "cannot have PRIVATE components", &code
->loc
))
8329 else if (derived_inaccessible (ts
->u
.derived
))
8331 gfc_error ("Data transfer element at %L cannot have "
8332 "PRIVATE components",&code
->loc
);
8337 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8338 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8340 gfc_error ("Data transfer element at %L cannot be a full reference to "
8341 "an assumed-size array", &code
->loc
);
8347 /*********** Toplevel code resolution subroutines ***********/
8349 /* Find the set of labels that are reachable from this block. We also
8350 record the last statement in each block. */
8353 find_reachable_labels (gfc_code
*block
)
8360 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8362 /* Collect labels in this block. We don't keep those corresponding
8363 to END {IF|SELECT}, these are checked in resolve_branch by going
8364 up through the code_stack. */
8365 for (c
= block
; c
; c
= c
->next
)
8367 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8368 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8371 /* Merge with labels from parent block. */
8374 gcc_assert (cs_base
->prev
->reachable_labels
);
8375 bitmap_ior_into (cs_base
->reachable_labels
,
8376 cs_base
->prev
->reachable_labels
);
8382 resolve_lock_unlock (gfc_code
*code
)
8384 if (code
->expr1
->ts
.type
!= BT_DERIVED
8385 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8386 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8387 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8388 || code
->expr1
->rank
!= 0
8389 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8390 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8391 &code
->expr1
->where
);
8395 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8396 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8397 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8398 &code
->expr2
->where
);
8401 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8402 _("STAT variable")))
8407 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8408 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8409 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8410 &code
->expr3
->where
);
8413 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8414 _("ERRMSG variable")))
8417 /* Check ACQUIRED_LOCK. */
8419 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8420 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8421 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8422 "variable", &code
->expr4
->where
);
8425 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8426 _("ACQUIRED_LOCK variable")))
8432 resolve_sync (gfc_code
*code
)
8434 /* Check imageset. The * case matches expr1 == NULL. */
8437 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8438 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8439 "INTEGER expression", &code
->expr1
->where
);
8440 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8441 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8442 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8443 &code
->expr1
->where
);
8444 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8445 && gfc_simplify_expr (code
->expr1
, 0))
8447 gfc_constructor
*cons
;
8448 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8449 for (; cons
; cons
= gfc_constructor_next (cons
))
8450 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8451 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8452 gfc_error ("Imageset argument at %L must between 1 and "
8453 "num_images()", &cons
->expr
->where
);
8459 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8460 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8461 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8462 &code
->expr2
->where
);
8466 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8467 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8468 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8469 &code
->expr3
->where
);
8473 /* Given a branch to a label, see if the branch is conforming.
8474 The code node describes where the branch is located. */
8477 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8484 /* Step one: is this a valid branching target? */
8486 if (label
->defined
== ST_LABEL_UNKNOWN
)
8488 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8493 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8495 gfc_error ("Statement at %L is not a valid branch target statement "
8496 "for the branch statement at %L", &label
->where
, &code
->loc
);
8500 /* Step two: make sure this branch is not a branch to itself ;-) */
8502 if (code
->here
== label
)
8504 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8508 /* Step three: See if the label is in the same block as the
8509 branching statement. The hard work has been done by setting up
8510 the bitmap reachable_labels. */
8512 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8514 /* Check now whether there is a CRITICAL construct; if so, check
8515 whether the label is still visible outside of the CRITICAL block,
8516 which is invalid. */
8517 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8519 if (stack
->current
->op
== EXEC_CRITICAL
8520 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8521 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8522 "label at %L", &code
->loc
, &label
->where
);
8523 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8524 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8525 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8526 "for label at %L", &code
->loc
, &label
->where
);
8532 /* Step four: If we haven't found the label in the bitmap, it may
8533 still be the label of the END of the enclosing block, in which
8534 case we find it by going up the code_stack. */
8536 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8538 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8540 if (stack
->current
->op
== EXEC_CRITICAL
)
8542 /* Note: A label at END CRITICAL does not leave the CRITICAL
8543 construct as END CRITICAL is still part of it. */
8544 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8545 " at %L", &code
->loc
, &label
->where
);
8548 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8550 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8551 "label at %L", &code
->loc
, &label
->where
);
8558 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8562 /* The label is not in an enclosing block, so illegal. This was
8563 allowed in Fortran 66, so we allow it as extension. No
8564 further checks are necessary in this case. */
8565 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8566 "as the GOTO statement at %L", &label
->where
,
8572 /* Check whether EXPR1 has the same shape as EXPR2. */
8575 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8577 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8578 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8579 bool result
= false;
8582 /* Compare the rank. */
8583 if (expr1
->rank
!= expr2
->rank
)
8586 /* Compare the size of each dimension. */
8587 for (i
=0; i
<expr1
->rank
; i
++)
8589 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8592 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8595 if (mpz_cmp (shape
[i
], shape2
[i
]))
8599 /* When either of the two expression is an assumed size array, we
8600 ignore the comparison of dimension sizes. */
8605 gfc_clear_shape (shape
, i
);
8606 gfc_clear_shape (shape2
, i
);
8611 /* Check whether a WHERE assignment target or a WHERE mask expression
8612 has the same shape as the outmost WHERE mask expression. */
8615 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8621 cblock
= code
->block
;
8623 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8624 In case of nested WHERE, only the outmost one is stored. */
8625 if (mask
== NULL
) /* outmost WHERE */
8627 else /* inner WHERE */
8634 /* Check if the mask-expr has a consistent shape with the
8635 outmost WHERE mask-expr. */
8636 if (!resolve_where_shape (cblock
->expr1
, e
))
8637 gfc_error ("WHERE mask at %L has inconsistent shape",
8638 &cblock
->expr1
->where
);
8641 /* the assignment statement of a WHERE statement, or the first
8642 statement in where-body-construct of a WHERE construct */
8643 cnext
= cblock
->next
;
8648 /* WHERE assignment statement */
8651 /* Check shape consistent for WHERE assignment target. */
8652 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8653 gfc_error ("WHERE assignment target at %L has "
8654 "inconsistent shape", &cnext
->expr1
->where
);
8658 case EXEC_ASSIGN_CALL
:
8659 resolve_call (cnext
);
8660 if (!cnext
->resolved_sym
->attr
.elemental
)
8661 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8662 &cnext
->ext
.actual
->expr
->where
);
8665 /* WHERE or WHERE construct is part of a where-body-construct */
8667 resolve_where (cnext
, e
);
8671 gfc_error ("Unsupported statement inside WHERE at %L",
8674 /* the next statement within the same where-body-construct */
8675 cnext
= cnext
->next
;
8677 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8678 cblock
= cblock
->block
;
8683 /* Resolve assignment in FORALL construct.
8684 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8685 FORALL index variables. */
8688 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8692 for (n
= 0; n
< nvar
; n
++)
8694 gfc_symbol
*forall_index
;
8696 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8698 /* Check whether the assignment target is one of the FORALL index
8700 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8701 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8702 gfc_error ("Assignment to a FORALL index variable at %L",
8703 &code
->expr1
->where
);
8706 /* If one of the FORALL index variables doesn't appear in the
8707 assignment variable, then there could be a many-to-one
8708 assignment. Emit a warning rather than an error because the
8709 mask could be resolving this problem. */
8710 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8711 gfc_warning ("The FORALL with index '%s' is not used on the "
8712 "left side of the assignment at %L and so might "
8713 "cause multiple assignment to this object",
8714 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8720 /* Resolve WHERE statement in FORALL construct. */
8723 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8724 gfc_expr
**var_expr
)
8729 cblock
= code
->block
;
8732 /* the assignment statement of a WHERE statement, or the first
8733 statement in where-body-construct of a WHERE construct */
8734 cnext
= cblock
->next
;
8739 /* WHERE assignment statement */
8741 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8744 /* WHERE operator assignment statement */
8745 case EXEC_ASSIGN_CALL
:
8746 resolve_call (cnext
);
8747 if (!cnext
->resolved_sym
->attr
.elemental
)
8748 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8749 &cnext
->ext
.actual
->expr
->where
);
8752 /* WHERE or WHERE construct is part of a where-body-construct */
8754 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8758 gfc_error ("Unsupported statement inside WHERE at %L",
8761 /* the next statement within the same where-body-construct */
8762 cnext
= cnext
->next
;
8764 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8765 cblock
= cblock
->block
;
8770 /* Traverse the FORALL body to check whether the following errors exist:
8771 1. For assignment, check if a many-to-one assignment happens.
8772 2. For WHERE statement, check the WHERE body to see if there is any
8773 many-to-one assignment. */
8776 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8780 c
= code
->block
->next
;
8786 case EXEC_POINTER_ASSIGN
:
8787 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8790 case EXEC_ASSIGN_CALL
:
8794 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8795 there is no need to handle it here. */
8799 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8804 /* The next statement in the FORALL body. */
8810 /* Counts the number of iterators needed inside a forall construct, including
8811 nested forall constructs. This is used to allocate the needed memory
8812 in gfc_resolve_forall. */
8815 gfc_count_forall_iterators (gfc_code
*code
)
8817 int max_iters
, sub_iters
, current_iters
;
8818 gfc_forall_iterator
*fa
;
8820 gcc_assert(code
->op
== EXEC_FORALL
);
8824 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8827 code
= code
->block
->next
;
8831 if (code
->op
== EXEC_FORALL
)
8833 sub_iters
= gfc_count_forall_iterators (code
);
8834 if (sub_iters
> max_iters
)
8835 max_iters
= sub_iters
;
8840 return current_iters
+ max_iters
;
8844 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8845 gfc_resolve_forall_body to resolve the FORALL body. */
8848 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8850 static gfc_expr
**var_expr
;
8851 static int total_var
= 0;
8852 static int nvar
= 0;
8854 gfc_forall_iterator
*fa
;
8859 /* Start to resolve a FORALL construct */
8860 if (forall_save
== 0)
8862 /* Count the total number of FORALL index in the nested FORALL
8863 construct in order to allocate the VAR_EXPR with proper size. */
8864 total_var
= gfc_count_forall_iterators (code
);
8866 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8867 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8870 /* The information about FORALL iterator, including FORALL index start, end
8871 and stride. The FORALL index can not appear in start, end or stride. */
8872 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8874 /* Check if any outer FORALL index name is the same as the current
8876 for (i
= 0; i
< nvar
; i
++)
8878 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8880 gfc_error ("An outer FORALL construct already has an index "
8881 "with this name %L", &fa
->var
->where
);
8885 /* Record the current FORALL index. */
8886 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8890 /* No memory leak. */
8891 gcc_assert (nvar
<= total_var
);
8894 /* Resolve the FORALL body. */
8895 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8897 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8898 gfc_resolve_blocks (code
->block
, ns
);
8902 /* Free only the VAR_EXPRs allocated in this frame. */
8903 for (i
= nvar
; i
< tmp
; i
++)
8904 gfc_free_expr (var_expr
[i
]);
8908 /* We are in the outermost FORALL construct. */
8909 gcc_assert (forall_save
== 0);
8911 /* VAR_EXPR is not needed any more. */
8918 /* Resolve a BLOCK construct statement. */
8921 resolve_block_construct (gfc_code
* code
)
8923 /* Resolve the BLOCK's namespace. */
8924 gfc_resolve (code
->ext
.block
.ns
);
8926 /* For an ASSOCIATE block, the associations (and their targets) are already
8927 resolved during resolve_symbol. */
8931 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8934 static void resolve_code (gfc_code
*, gfc_namespace
*);
8937 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8941 for (; b
; b
= b
->block
)
8943 t
= gfc_resolve_expr (b
->expr1
);
8944 if (!gfc_resolve_expr (b
->expr2
))
8950 if (t
&& b
->expr1
!= NULL
8951 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8952 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8959 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8960 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8965 resolve_branch (b
->label1
, b
);
8969 resolve_block_construct (b
);
8973 case EXEC_SELECT_TYPE
:
8977 case EXEC_DO_CONCURRENT
:
8985 case EXEC_OMP_ATOMIC
:
8986 case EXEC_OMP_CRITICAL
:
8988 case EXEC_OMP_MASTER
:
8989 case EXEC_OMP_ORDERED
:
8990 case EXEC_OMP_PARALLEL
:
8991 case EXEC_OMP_PARALLEL_DO
:
8992 case EXEC_OMP_PARALLEL_SECTIONS
:
8993 case EXEC_OMP_PARALLEL_WORKSHARE
:
8994 case EXEC_OMP_SECTIONS
:
8995 case EXEC_OMP_SINGLE
:
8997 case EXEC_OMP_TASKWAIT
:
8998 case EXEC_OMP_TASKYIELD
:
8999 case EXEC_OMP_WORKSHARE
:
9003 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9006 resolve_code (b
->next
, ns
);
9011 /* Does everything to resolve an ordinary assignment. Returns true
9012 if this is an interface assignment. */
9014 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9024 if (gfc_extend_assign (code
, ns
))
9028 if (code
->op
== EXEC_ASSIGN_CALL
)
9030 lhs
= code
->ext
.actual
->expr
;
9031 rhsptr
= &code
->ext
.actual
->next
->expr
;
9035 gfc_actual_arglist
* args
;
9036 gfc_typebound_proc
* tbp
;
9038 gcc_assert (code
->op
== EXEC_COMPCALL
);
9040 args
= code
->expr1
->value
.compcall
.actual
;
9042 rhsptr
= &args
->next
->expr
;
9044 tbp
= code
->expr1
->value
.compcall
.tbp
;
9045 gcc_assert (!tbp
->is_generic
);
9048 /* Make a temporary rhs when there is a default initializer
9049 and rhs is the same symbol as the lhs. */
9050 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9051 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9052 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9053 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9054 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9063 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9064 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9068 /* Handle the case of a BOZ literal on the RHS. */
9069 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9072 if (gfc_option
.warn_surprising
)
9073 gfc_warning ("BOZ literal at %L is bitwise transferred "
9074 "non-integer symbol '%s'", &code
->loc
,
9075 lhs
->symtree
->n
.sym
->name
);
9077 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9079 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9081 if (rc
== ARITH_UNDERFLOW
)
9082 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9083 ". This check can be disabled with the option "
9084 "-fno-range-check", &rhs
->where
);
9085 else if (rc
== ARITH_OVERFLOW
)
9086 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9087 ". This check can be disabled with the option "
9088 "-fno-range-check", &rhs
->where
);
9089 else if (rc
== ARITH_NAN
)
9090 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9091 ". This check can be disabled with the option "
9092 "-fno-range-check", &rhs
->where
);
9097 if (lhs
->ts
.type
== BT_CHARACTER
9098 && gfc_option
.warn_character_truncation
)
9100 if (lhs
->ts
.u
.cl
!= NULL
9101 && lhs
->ts
.u
.cl
->length
!= NULL
9102 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9103 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9105 if (rhs
->expr_type
== EXPR_CONSTANT
)
9106 rlen
= rhs
->value
.character
.length
;
9108 else if (rhs
->ts
.u
.cl
!= NULL
9109 && rhs
->ts
.u
.cl
->length
!= NULL
9110 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9111 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9113 if (rlen
&& llen
&& rlen
> llen
)
9114 gfc_warning_now ("CHARACTER expression will be truncated "
9115 "in assignment (%d/%d) at %L",
9116 llen
, rlen
, &code
->loc
);
9119 /* Ensure that a vector index expression for the lvalue is evaluated
9120 to a temporary if the lvalue symbol is referenced in it. */
9123 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9124 if (ref
->type
== REF_ARRAY
)
9126 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9127 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9128 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9129 ref
->u
.ar
.start
[n
]))
9131 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9135 if (gfc_pure (NULL
))
9137 if (lhs
->ts
.type
== BT_DERIVED
9138 && lhs
->expr_type
== EXPR_VARIABLE
9139 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9140 && rhs
->expr_type
== EXPR_VARIABLE
9141 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9142 || gfc_is_coindexed (rhs
)))
9145 if (gfc_is_coindexed (rhs
))
9146 gfc_error ("Coindexed expression at %L is assigned to "
9147 "a derived type variable with a POINTER "
9148 "component in a PURE procedure",
9151 gfc_error ("The impure variable at %L is assigned to "
9152 "a derived type variable with a POINTER "
9153 "component in a PURE procedure (12.6)",
9158 /* Fortran 2008, C1283. */
9159 if (gfc_is_coindexed (lhs
))
9161 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9162 "procedure", &rhs
->where
);
9167 if (gfc_implicit_pure (NULL
))
9169 if (lhs
->expr_type
== EXPR_VARIABLE
9170 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9171 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9172 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9174 if (lhs
->ts
.type
== BT_DERIVED
9175 && lhs
->expr_type
== EXPR_VARIABLE
9176 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9177 && rhs
->expr_type
== EXPR_VARIABLE
9178 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9179 || gfc_is_coindexed (rhs
)))
9180 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9182 /* Fortran 2008, C1283. */
9183 if (gfc_is_coindexed (lhs
))
9184 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9188 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9189 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9190 if (lhs
->ts
.type
== BT_CLASS
)
9192 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9193 "%L - check that there is a matching specific subroutine "
9194 "for '=' operator", &lhs
->where
);
9198 /* F2008, Section 7.2.1.2. */
9199 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9201 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9202 "component in assignment at %L", &lhs
->where
);
9206 gfc_check_assign (lhs
, rhs
, 1);
9211 /* Add a component reference onto an expression. */
9214 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9219 ref
= &((*ref
)->next
);
9220 *ref
= gfc_get_ref ();
9221 (*ref
)->type
= REF_COMPONENT
;
9222 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9223 (*ref
)->u
.c
.component
= c
;
9226 /* Add a full array ref, as necessary. */
9229 gfc_add_full_array_ref (e
, c
->as
);
9230 e
->rank
= c
->as
->rank
;
9235 /* Build an assignment. Keep the argument 'op' for future use, so that
9236 pointer assignments can be made. */
9239 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9240 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9242 gfc_code
*this_code
;
9244 this_code
= gfc_get_code ();
9246 this_code
->next
= NULL
;
9247 this_code
->expr1
= gfc_copy_expr (expr1
);
9248 this_code
->expr2
= gfc_copy_expr (expr2
);
9249 this_code
->loc
= loc
;
9252 add_comp_ref (this_code
->expr1
, comp1
);
9253 add_comp_ref (this_code
->expr2
, comp2
);
9260 /* Makes a temporary variable expression based on the characteristics of
9261 a given variable expression. */
9264 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9266 static int serial
= 0;
9267 char name
[GFC_MAX_SYMBOL_LEN
];
9270 gfc_array_ref
*aref
;
9273 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9274 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9275 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9281 /* This function could be expanded to support other expression type
9282 but this is not needed here. */
9283 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9285 /* Obtain the arrayspec for the temporary. */
9288 aref
= gfc_find_array_ref (e
);
9289 if (e
->expr_type
== EXPR_VARIABLE
9290 && e
->symtree
->n
.sym
->as
== aref
->as
)
9294 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9295 if (ref
->type
== REF_COMPONENT
9296 && ref
->u
.c
.component
->as
== aref
->as
)
9304 /* Add the attributes and the arrayspec to the temporary. */
9305 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9306 tmp
->n
.sym
->attr
.function
= 0;
9307 tmp
->n
.sym
->attr
.result
= 0;
9308 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9312 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9315 if (as
->type
== AS_DEFERRED
)
9316 tmp
->n
.sym
->attr
.allocatable
= 1;
9319 tmp
->n
.sym
->attr
.dimension
= 0;
9321 gfc_set_sym_referenced (tmp
->n
.sym
);
9322 gfc_commit_symbol (tmp
->n
.sym
);
9323 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9325 /* Should the lhs be a section, use its array ref for the
9326 temporary expression. */
9327 if (aref
&& aref
->type
!= AR_FULL
)
9329 gfc_free_ref_list (e
->ref
);
9330 e
->ref
= gfc_copy_ref (ref
);
9336 /* Add one line of code to the code chain, making sure that 'head' and
9337 'tail' are appropriately updated. */
9340 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9342 gcc_assert (this_code
);
9344 *head
= *tail
= *this_code
;
9346 *tail
= gfc_append_code (*tail
, *this_code
);
9351 /* Counts the potential number of part array references that would
9352 result from resolution of typebound defined assignments. */
9355 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9358 int c_depth
= 0, t_depth
;
9360 for (c
= derived
->components
; c
; c
= c
->next
)
9362 if ((c
->ts
.type
!= BT_DERIVED
9364 || c
->attr
.allocatable
9365 || c
->attr
.proc_pointer_comp
9366 || c
->attr
.class_pointer
9367 || c
->attr
.proc_pointer
)
9368 && !c
->attr
.defined_assign_comp
)
9371 if (c
->as
&& c_depth
== 0)
9374 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9375 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9380 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9382 return depth
+ c_depth
;
9386 /* Implement 7.2.1.3 of the F08 standard:
9387 "An intrinsic assignment where the variable is of derived type is
9388 performed as if each component of the variable were assigned from the
9389 corresponding component of expr using pointer assignment (7.2.2) for
9390 each pointer component, defined assignment for each nonpointer
9391 nonallocatable component of a type that has a type-bound defined
9392 assignment consistent with the component, intrinsic assignment for
9393 each other nonpointer nonallocatable component, ..."
9395 The pointer assignments are taken care of by the intrinsic
9396 assignment of the structure itself. This function recursively adds
9397 defined assignments where required. The recursion is accomplished
9398 by calling resolve_code.
9400 When the lhs in a defined assignment has intent INOUT, we need a
9401 temporary for the lhs. In pseudo-code:
9403 ! Only call function lhs once.
9404 if (lhs is not a constant or an variable)
9407 ! Do the intrinsic assignment
9409 ! Now do the defined assignments
9410 do over components with typebound defined assignment [%cmp]
9411 #if one component's assignment procedure is INOUT
9413 #if expr2 non-variable
9419 t1%cmp {defined=} expr2%cmp
9425 expr1%cmp {defined=} expr2%cmp
9429 /* The temporary assignments have to be put on top of the additional
9430 code to avoid the result being changed by the intrinsic assignment.
9432 static int component_assignment_level
= 0;
9433 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9436 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9438 gfc_component
*comp1
, *comp2
;
9439 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9441 int error_count
, depth
;
9443 gfc_get_errors (NULL
, &error_count
);
9445 /* Filter out continuing processing after an error. */
9447 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9448 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9451 /* TODO: Handle more than one part array reference in assignments. */
9452 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9453 (*code
)->expr1
->rank
? 1 : 0);
9456 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9457 "done because multiple part array references would "
9458 "occur in intermediate expressions.", &(*code
)->loc
);
9462 component_assignment_level
++;
9464 /* Create a temporary so that functions get called only once. */
9465 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9466 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9470 /* Assign the rhs to the temporary. */
9471 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9472 this_code
= build_assignment (EXEC_ASSIGN
,
9473 tmp_expr
, (*code
)->expr2
,
9474 NULL
, NULL
, (*code
)->loc
);
9475 /* Add the code and substitute the rhs expression. */
9476 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9477 gfc_free_expr ((*code
)->expr2
);
9478 (*code
)->expr2
= tmp_expr
;
9481 /* Do the intrinsic assignment. This is not needed if the lhs is one
9482 of the temporaries generated here, since the intrinsic assignment
9483 to the final result already does this. */
9484 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9486 this_code
= build_assignment (EXEC_ASSIGN
,
9487 (*code
)->expr1
, (*code
)->expr2
,
9488 NULL
, NULL
, (*code
)->loc
);
9489 add_code_to_chain (&this_code
, &head
, &tail
);
9492 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9493 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9496 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9500 /* The intrinsic assignment does the right thing for pointers
9501 of all kinds and allocatable components. */
9502 if (comp1
->ts
.type
!= BT_DERIVED
9503 || comp1
->attr
.pointer
9504 || comp1
->attr
.allocatable
9505 || comp1
->attr
.proc_pointer_comp
9506 || comp1
->attr
.class_pointer
9507 || comp1
->attr
.proc_pointer
)
9510 /* Make an assigment for this component. */
9511 this_code
= build_assignment (EXEC_ASSIGN
,
9512 (*code
)->expr1
, (*code
)->expr2
,
9513 comp1
, comp2
, (*code
)->loc
);
9515 /* Convert the assignment if there is a defined assignment for
9516 this type. Otherwise, using the call from resolve_code,
9517 recurse into its components. */
9518 resolve_code (this_code
, ns
);
9520 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9522 gfc_formal_arglist
*dummy_args
;
9524 /* Check that there is a typebound defined assignment. If not,
9525 then this must be a module defined assignment. We cannot
9526 use the defined_assign_comp attribute here because it must
9527 be this derived type that has the defined assignment and not
9529 if (!(comp1
->ts
.u
.derived
->f2k_derived
9530 && comp1
->ts
.u
.derived
->f2k_derived
9531 ->tb_op
[INTRINSIC_ASSIGN
]))
9533 gfc_free_statements (this_code
);
9538 /* If the first argument of the subroutine has intent INOUT
9539 a temporary must be generated and used instead. */
9540 rsym
= this_code
->resolved_sym
;
9541 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9543 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9545 gfc_code
*temp_code
;
9548 /* Build the temporary required for the assignment and put
9549 it at the head of the generated code. */
9552 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9553 temp_code
= build_assignment (EXEC_ASSIGN
,
9555 NULL
, NULL
, (*code
)->loc
);
9556 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9559 /* Replace the first actual arg with the component of the
9561 gfc_free_expr (this_code
->ext
.actual
->expr
);
9562 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9563 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9566 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9568 /* Don't add intrinsic assignments since they are already
9569 effected by the intrinsic assignment of the structure. */
9570 gfc_free_statements (this_code
);
9575 add_code_to_chain (&this_code
, &head
, &tail
);
9579 /* Transfer the value to the final result. */
9580 this_code
= build_assignment (EXEC_ASSIGN
,
9582 comp1
, comp2
, (*code
)->loc
);
9583 add_code_to_chain (&this_code
, &head
, &tail
);
9587 /* This is probably not necessary. */
9590 gfc_free_statements (this_code
);
9594 /* Put the temporary assignments at the top of the generated code. */
9595 if (tmp_head
&& component_assignment_level
== 1)
9597 gfc_append_code (tmp_head
, head
);
9599 tmp_head
= tmp_tail
= NULL
;
9602 /* Now attach the remaining code chain to the input code. Step on
9603 to the end of the new code since resolution is complete. */
9604 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9605 tail
->next
= (*code
)->next
;
9606 /* Overwrite 'code' because this would place the intrinsic assignment
9607 before the temporary for the lhs is created. */
9608 gfc_free_expr ((*code
)->expr1
);
9609 gfc_free_expr ((*code
)->expr2
);
9614 component_assignment_level
--;
9618 /* Given a block of code, recursively resolve everything pointed to by this
9622 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9624 int omp_workshare_save
;
9625 int forall_save
, do_concurrent_save
;
9629 frame
.prev
= cs_base
;
9633 find_reachable_labels (code
);
9635 for (; code
; code
= code
->next
)
9637 frame
.current
= code
;
9638 forall_save
= forall_flag
;
9639 do_concurrent_save
= do_concurrent_flag
;
9641 if (code
->op
== EXEC_FORALL
)
9644 gfc_resolve_forall (code
, ns
, forall_save
);
9647 else if (code
->block
)
9649 omp_workshare_save
= -1;
9652 case EXEC_OMP_PARALLEL_WORKSHARE
:
9653 omp_workshare_save
= omp_workshare_flag
;
9654 omp_workshare_flag
= 1;
9655 gfc_resolve_omp_parallel_blocks (code
, ns
);
9657 case EXEC_OMP_PARALLEL
:
9658 case EXEC_OMP_PARALLEL_DO
:
9659 case EXEC_OMP_PARALLEL_SECTIONS
:
9661 omp_workshare_save
= omp_workshare_flag
;
9662 omp_workshare_flag
= 0;
9663 gfc_resolve_omp_parallel_blocks (code
, ns
);
9666 gfc_resolve_omp_do_blocks (code
, ns
);
9668 case EXEC_SELECT_TYPE
:
9669 /* Blocks are handled in resolve_select_type because we have
9670 to transform the SELECT TYPE into ASSOCIATE first. */
9672 case EXEC_DO_CONCURRENT
:
9673 do_concurrent_flag
= 1;
9674 gfc_resolve_blocks (code
->block
, ns
);
9675 do_concurrent_flag
= 2;
9677 case EXEC_OMP_WORKSHARE
:
9678 omp_workshare_save
= omp_workshare_flag
;
9679 omp_workshare_flag
= 1;
9682 gfc_resolve_blocks (code
->block
, ns
);
9686 if (omp_workshare_save
!= -1)
9687 omp_workshare_flag
= omp_workshare_save
;
9691 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9692 t
= gfc_resolve_expr (code
->expr1
);
9693 forall_flag
= forall_save
;
9694 do_concurrent_flag
= do_concurrent_save
;
9696 if (!gfc_resolve_expr (code
->expr2
))
9699 if (code
->op
== EXEC_ALLOCATE
9700 && !gfc_resolve_expr (code
->expr3
))
9706 case EXEC_END_BLOCK
:
9707 case EXEC_END_NESTED_BLOCK
:
9711 case EXEC_ERROR_STOP
:
9715 case EXEC_ASSIGN_CALL
:
9720 case EXEC_SYNC_IMAGES
:
9721 case EXEC_SYNC_MEMORY
:
9722 resolve_sync (code
);
9727 resolve_lock_unlock (code
);
9731 /* Keep track of which entry we are up to. */
9732 current_entry_id
= code
->ext
.entry
->id
;
9736 resolve_where (code
, NULL
);
9740 if (code
->expr1
!= NULL
)
9742 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9743 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9744 "INTEGER variable", &code
->expr1
->where
);
9745 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9746 gfc_error ("Variable '%s' has not been assigned a target "
9747 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9748 &code
->expr1
->where
);
9751 resolve_branch (code
->label1
, code
);
9755 if (code
->expr1
!= NULL
9756 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9757 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9758 "INTEGER return specifier", &code
->expr1
->where
);
9761 case EXEC_INIT_ASSIGN
:
9762 case EXEC_END_PROCEDURE
:
9769 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
9773 if (resolve_ordinary_assign (code
, ns
))
9775 if (code
->op
== EXEC_COMPCALL
)
9781 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
9782 if (code
->expr1
->ts
.type
== BT_DERIVED
9783 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
9784 generate_component_assignments (&code
, ns
);
9788 case EXEC_LABEL_ASSIGN
:
9789 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9790 gfc_error ("Label %d referenced at %L is never defined",
9791 code
->label1
->value
, &code
->label1
->where
);
9793 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9794 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9795 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9796 != gfc_default_integer_kind
9797 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9798 gfc_error ("ASSIGN statement at %L requires a scalar "
9799 "default INTEGER variable", &code
->expr1
->where
);
9802 case EXEC_POINTER_ASSIGN
:
9809 /* This is both a variable definition and pointer assignment
9810 context, so check both of them. For rank remapping, a final
9811 array ref may be present on the LHS and fool gfc_expr_attr
9812 used in gfc_check_vardef_context. Remove it. */
9813 e
= remove_last_array_ref (code
->expr1
);
9814 t
= gfc_check_vardef_context (e
, true, false, false,
9815 _("pointer assignment"));
9817 t
= gfc_check_vardef_context (e
, false, false, false,
9818 _("pointer assignment"));
9823 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9827 case EXEC_ARITHMETIC_IF
:
9829 && code
->expr1
->ts
.type
!= BT_INTEGER
9830 && code
->expr1
->ts
.type
!= BT_REAL
)
9831 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9832 "expression", &code
->expr1
->where
);
9834 resolve_branch (code
->label1
, code
);
9835 resolve_branch (code
->label2
, code
);
9836 resolve_branch (code
->label3
, code
);
9840 if (t
&& code
->expr1
!= NULL
9841 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9842 || code
->expr1
->rank
!= 0))
9843 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9844 &code
->expr1
->where
);
9849 resolve_call (code
);
9854 resolve_typebound_subroutine (code
);
9858 resolve_ppc_call (code
);
9862 /* Select is complicated. Also, a SELECT construct could be
9863 a transformed computed GOTO. */
9864 resolve_select (code
, false);
9867 case EXEC_SELECT_TYPE
:
9868 resolve_select_type (code
, ns
);
9872 resolve_block_construct (code
);
9876 if (code
->ext
.iterator
!= NULL
)
9878 gfc_iterator
*iter
= code
->ext
.iterator
;
9879 if (gfc_resolve_iterator (iter
, true, false))
9880 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9885 if (code
->expr1
== NULL
)
9886 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9888 && (code
->expr1
->rank
!= 0
9889 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9890 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9891 "a scalar LOGICAL expression", &code
->expr1
->where
);
9896 resolve_allocate_deallocate (code
, "ALLOCATE");
9900 case EXEC_DEALLOCATE
:
9902 resolve_allocate_deallocate (code
, "DEALLOCATE");
9907 if (!gfc_resolve_open (code
->ext
.open
))
9910 resolve_branch (code
->ext
.open
->err
, code
);
9914 if (!gfc_resolve_close (code
->ext
.close
))
9917 resolve_branch (code
->ext
.close
->err
, code
);
9920 case EXEC_BACKSPACE
:
9924 if (!gfc_resolve_filepos (code
->ext
.filepos
))
9927 resolve_branch (code
->ext
.filepos
->err
, code
);
9931 if (!gfc_resolve_inquire (code
->ext
.inquire
))
9934 resolve_branch (code
->ext
.inquire
->err
, code
);
9938 gcc_assert (code
->ext
.inquire
!= NULL
);
9939 if (!gfc_resolve_inquire (code
->ext
.inquire
))
9942 resolve_branch (code
->ext
.inquire
->err
, code
);
9946 if (!gfc_resolve_wait (code
->ext
.wait
))
9949 resolve_branch (code
->ext
.wait
->err
, code
);
9950 resolve_branch (code
->ext
.wait
->end
, code
);
9951 resolve_branch (code
->ext
.wait
->eor
, code
);
9956 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
9959 resolve_branch (code
->ext
.dt
->err
, code
);
9960 resolve_branch (code
->ext
.dt
->end
, code
);
9961 resolve_branch (code
->ext
.dt
->eor
, code
);
9965 resolve_transfer (code
);
9968 case EXEC_DO_CONCURRENT
:
9970 resolve_forall_iterators (code
->ext
.forall_iterator
);
9972 if (code
->expr1
!= NULL
9973 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9974 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9975 "expression", &code
->expr1
->where
);
9978 case EXEC_OMP_ATOMIC
:
9979 case EXEC_OMP_BARRIER
:
9980 case EXEC_OMP_CRITICAL
:
9981 case EXEC_OMP_FLUSH
:
9983 case EXEC_OMP_MASTER
:
9984 case EXEC_OMP_ORDERED
:
9985 case EXEC_OMP_SECTIONS
:
9986 case EXEC_OMP_SINGLE
:
9987 case EXEC_OMP_TASKWAIT
:
9988 case EXEC_OMP_TASKYIELD
:
9989 case EXEC_OMP_WORKSHARE
:
9990 gfc_resolve_omp_directive (code
, ns
);
9993 case EXEC_OMP_PARALLEL
:
9994 case EXEC_OMP_PARALLEL_DO
:
9995 case EXEC_OMP_PARALLEL_SECTIONS
:
9996 case EXEC_OMP_PARALLEL_WORKSHARE
:
9998 omp_workshare_save
= omp_workshare_flag
;
9999 omp_workshare_flag
= 0;
10000 gfc_resolve_omp_directive (code
, ns
);
10001 omp_workshare_flag
= omp_workshare_save
;
10005 gfc_internal_error ("resolve_code(): Bad statement code");
10009 cs_base
= frame
.prev
;
10013 /* Resolve initial values and make sure they are compatible with
10017 resolve_values (gfc_symbol
*sym
)
10021 if (sym
->value
== NULL
)
10024 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10025 t
= resolve_structure_cons (sym
->value
, 1);
10027 t
= gfc_resolve_expr (sym
->value
);
10032 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10036 /* Verify any BIND(C) derived types in the namespace so we can report errors
10037 for them once, rather than for each variable declared of that type. */
10040 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10042 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10043 && derived_sym
->attr
.is_bind_c
== 1)
10044 verify_bind_c_derived_type (derived_sym
);
10050 /* Verify that any binding labels used in a given namespace do not collide
10051 with the names or binding labels of any global symbols. Multiple INTERFACE
10052 for the same procedure are permitted. */
10055 gfc_verify_binding_labels (gfc_symbol
*sym
)
10058 const char *module
;
10060 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10061 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10064 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10067 module
= sym
->module
;
10068 else if (sym
->ns
&& sym
->ns
->proc_name
10069 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10070 module
= sym
->ns
->proc_name
->name
;
10071 else if (sym
->ns
&& sym
->ns
->parent
10072 && sym
->ns
&& sym
->ns
->parent
->proc_name
10073 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10074 module
= sym
->ns
->parent
->proc_name
->name
;
10080 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10083 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10084 gsym
->where
= sym
->declared_at
;
10085 gsym
->sym_name
= sym
->name
;
10086 gsym
->binding_label
= sym
->binding_label
;
10087 gsym
->binding_label
= sym
->binding_label
;
10088 gsym
->ns
= sym
->ns
;
10089 gsym
->mod_name
= module
;
10090 if (sym
->attr
.function
)
10091 gsym
->type
= GSYM_FUNCTION
;
10092 else if (sym
->attr
.subroutine
)
10093 gsym
->type
= GSYM_SUBROUTINE
;
10094 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10095 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10099 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10101 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10102 "identifier as entity at %L", sym
->name
,
10103 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10104 /* Clear the binding label to prevent checking multiple times. */
10105 sym
->binding_label
= NULL
;
10108 else if (sym
->attr
.flavor
== FL_VARIABLE
10109 && (strcmp (module
, gsym
->mod_name
) != 0
10110 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10112 /* This can only happen if the variable is defined in a module - if it
10113 isn't the same module, reject it. */
10114 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10115 "the same global identifier as entity at %L from module %s",
10116 sym
->name
, module
, sym
->binding_label
,
10117 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10118 sym
->binding_label
= NULL
;
10120 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10121 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10122 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10123 && sym
!= gsym
->ns
->proc_name
10124 && (strcmp (gsym
->sym_name
, sym
->name
) != 0
10125 || module
!= gsym
->mod_name
10126 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10128 /* Print an error if the procdure is defined multiple times; we have to
10129 exclude references to the same procedure via module association or
10130 multiple checks for the same procedure. */
10131 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10132 "global identifier as entity at %L", sym
->name
,
10133 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10134 sym
->binding_label
= NULL
;
10139 /* Resolve an index expression. */
10142 resolve_index_expr (gfc_expr
*e
)
10144 if (!gfc_resolve_expr (e
))
10147 if (!gfc_simplify_expr (e
, 0))
10150 if (!gfc_specification_expr (e
))
10157 /* Resolve a charlen structure. */
10160 resolve_charlen (gfc_charlen
*cl
)
10163 bool saved_specification_expr
;
10169 saved_specification_expr
= specification_expr
;
10170 specification_expr
= true;
10172 if (cl
->length_from_typespec
)
10174 if (!gfc_resolve_expr (cl
->length
))
10176 specification_expr
= saved_specification_expr
;
10180 if (!gfc_simplify_expr (cl
->length
, 0))
10182 specification_expr
= saved_specification_expr
;
10189 if (!resolve_index_expr (cl
->length
))
10191 specification_expr
= saved_specification_expr
;
10196 /* "If the character length parameter value evaluates to a negative
10197 value, the length of character entities declared is zero." */
10198 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10200 if (gfc_option
.warn_surprising
)
10201 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10202 " the length has been set to zero",
10203 &cl
->length
->where
, i
);
10204 gfc_replace_expr (cl
->length
,
10205 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10208 /* Check that the character length is not too large. */
10209 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10210 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10211 && cl
->length
->ts
.type
== BT_INTEGER
10212 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10214 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10215 specification_expr
= saved_specification_expr
;
10219 specification_expr
= saved_specification_expr
;
10224 /* Test for non-constant shape arrays. */
10227 is_non_constant_shape_array (gfc_symbol
*sym
)
10233 not_constant
= false;
10234 if (sym
->as
!= NULL
)
10236 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10237 has not been simplified; parameter array references. Do the
10238 simplification now. */
10239 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10241 e
= sym
->as
->lower
[i
];
10242 if (e
&& (!resolve_index_expr(e
)
10243 || !gfc_is_constant_expr (e
)))
10244 not_constant
= true;
10245 e
= sym
->as
->upper
[i
];
10246 if (e
&& (!resolve_index_expr(e
)
10247 || !gfc_is_constant_expr (e
)))
10248 not_constant
= true;
10251 return not_constant
;
10254 /* Given a symbol and an initialization expression, add code to initialize
10255 the symbol to the function entry. */
10257 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10261 gfc_namespace
*ns
= sym
->ns
;
10263 /* Search for the function namespace if this is a contained
10264 function without an explicit result. */
10265 if (sym
->attr
.function
&& sym
== sym
->result
10266 && sym
->name
!= sym
->ns
->proc_name
->name
)
10268 ns
= ns
->contained
;
10269 for (;ns
; ns
= ns
->sibling
)
10270 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10276 gfc_free_expr (init
);
10280 /* Build an l-value expression for the result. */
10281 lval
= gfc_lval_expr_from_sym (sym
);
10283 /* Add the code at scope entry. */
10284 init_st
= gfc_get_code ();
10285 init_st
->next
= ns
->code
;
10286 ns
->code
= init_st
;
10288 /* Assign the default initializer to the l-value. */
10289 init_st
->loc
= sym
->declared_at
;
10290 init_st
->op
= EXEC_INIT_ASSIGN
;
10291 init_st
->expr1
= lval
;
10292 init_st
->expr2
= init
;
10295 /* Assign the default initializer to a derived type variable or result. */
10298 apply_default_init (gfc_symbol
*sym
)
10300 gfc_expr
*init
= NULL
;
10302 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10305 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10306 init
= gfc_default_initializer (&sym
->ts
);
10308 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10311 build_init_assign (sym
, init
);
10312 sym
->attr
.referenced
= 1;
10315 /* Build an initializer for a local integer, real, complex, logical, or
10316 character variable, based on the command line flags finit-local-zero,
10317 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10318 null if the symbol should not have a default initialization. */
10320 build_default_init_expr (gfc_symbol
*sym
)
10323 gfc_expr
*init_expr
;
10326 /* These symbols should never have a default initialization. */
10327 if (sym
->attr
.allocatable
10328 || sym
->attr
.external
10330 || sym
->attr
.pointer
10331 || sym
->attr
.in_equivalence
10332 || sym
->attr
.in_common
10335 || sym
->attr
.cray_pointee
10336 || sym
->attr
.cray_pointer
10340 /* Now we'll try to build an initializer expression. */
10341 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10342 &sym
->declared_at
);
10344 /* We will only initialize integers, reals, complex, logicals, and
10345 characters, and only if the corresponding command-line flags
10346 were set. Otherwise, we free init_expr and return null. */
10347 switch (sym
->ts
.type
)
10350 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10351 mpz_set_si (init_expr
->value
.integer
,
10352 gfc_option
.flag_init_integer_value
);
10355 gfc_free_expr (init_expr
);
10361 switch (gfc_option
.flag_init_real
)
10363 case GFC_INIT_REAL_SNAN
:
10364 init_expr
->is_snan
= 1;
10365 /* Fall through. */
10366 case GFC_INIT_REAL_NAN
:
10367 mpfr_set_nan (init_expr
->value
.real
);
10370 case GFC_INIT_REAL_INF
:
10371 mpfr_set_inf (init_expr
->value
.real
, 1);
10374 case GFC_INIT_REAL_NEG_INF
:
10375 mpfr_set_inf (init_expr
->value
.real
, -1);
10378 case GFC_INIT_REAL_ZERO
:
10379 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10383 gfc_free_expr (init_expr
);
10390 switch (gfc_option
.flag_init_real
)
10392 case GFC_INIT_REAL_SNAN
:
10393 init_expr
->is_snan
= 1;
10394 /* Fall through. */
10395 case GFC_INIT_REAL_NAN
:
10396 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10397 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10400 case GFC_INIT_REAL_INF
:
10401 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10402 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10405 case GFC_INIT_REAL_NEG_INF
:
10406 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10407 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10410 case GFC_INIT_REAL_ZERO
:
10411 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10415 gfc_free_expr (init_expr
);
10422 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10423 init_expr
->value
.logical
= 0;
10424 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10425 init_expr
->value
.logical
= 1;
10428 gfc_free_expr (init_expr
);
10434 /* For characters, the length must be constant in order to
10435 create a default initializer. */
10436 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10437 && sym
->ts
.u
.cl
->length
10438 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10440 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10441 init_expr
->value
.character
.length
= char_len
;
10442 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10443 for (i
= 0; i
< char_len
; i
++)
10444 init_expr
->value
.character
.string
[i
]
10445 = (unsigned char) gfc_option
.flag_init_character_value
;
10449 gfc_free_expr (init_expr
);
10452 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10453 && sym
->ts
.u
.cl
->length
)
10455 gfc_actual_arglist
*arg
;
10456 init_expr
= gfc_get_expr ();
10457 init_expr
->where
= sym
->declared_at
;
10458 init_expr
->ts
= sym
->ts
;
10459 init_expr
->expr_type
= EXPR_FUNCTION
;
10460 init_expr
->value
.function
.isym
=
10461 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10462 init_expr
->value
.function
.name
= "repeat";
10463 arg
= gfc_get_actual_arglist ();
10464 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10466 arg
->expr
->value
.character
.string
[0]
10467 = gfc_option
.flag_init_character_value
;
10468 arg
->next
= gfc_get_actual_arglist ();
10469 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10470 init_expr
->value
.function
.actual
= arg
;
10475 gfc_free_expr (init_expr
);
10481 /* Add an initialization expression to a local variable. */
10483 apply_default_init_local (gfc_symbol
*sym
)
10485 gfc_expr
*init
= NULL
;
10487 /* The symbol should be a variable or a function return value. */
10488 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10489 || (sym
->attr
.function
&& sym
->result
!= sym
))
10492 /* Try to build the initializer expression. If we can't initialize
10493 this symbol, then init will be NULL. */
10494 init
= build_default_init_expr (sym
);
10498 /* For saved variables, we don't want to add an initializer at function
10499 entry, so we just add a static initializer. Note that automatic variables
10500 are stack allocated even with -fno-automatic; we have also to exclude
10501 result variable, which are also nonstatic. */
10502 if (sym
->attr
.save
|| sym
->ns
->save_all
10503 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10504 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10506 /* Don't clobber an existing initializer! */
10507 gcc_assert (sym
->value
== NULL
);
10512 build_init_assign (sym
, init
);
10516 /* Resolution of common features of flavors variable and procedure. */
10519 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10521 gfc_array_spec
*as
;
10523 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10524 as
= CLASS_DATA (sym
)->as
;
10528 /* Constraints on deferred shape variable. */
10529 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10531 bool pointer
, allocatable
, dimension
;
10533 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10535 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10536 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10537 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10541 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10542 allocatable
= sym
->attr
.allocatable
;
10543 dimension
= sym
->attr
.dimension
;
10548 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10550 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10551 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10554 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10555 "'%s' at %L may not be ALLOCATABLE",
10556 sym
->name
, &sym
->declared_at
))
10560 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10562 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10563 "assumed rank", sym
->name
, &sym
->declared_at
);
10569 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10570 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10572 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10573 sym
->name
, &sym
->declared_at
);
10578 /* Constraints on polymorphic variables. */
10579 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10582 if (sym
->attr
.class_ok
10583 && !sym
->attr
.select_type_temporary
10584 && !UNLIMITED_POLY (sym
)
10585 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10587 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10588 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10589 &sym
->declared_at
);
10594 /* Assume that use associated symbols were checked in the module ns.
10595 Class-variables that are associate-names are also something special
10596 and excepted from the test. */
10597 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10599 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10600 "or pointer", sym
->name
, &sym
->declared_at
);
10609 /* Additional checks for symbols with flavor variable and derived
10610 type. To be called from resolve_fl_variable. */
10613 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10615 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10617 /* Check to see if a derived type is blocked from being host
10618 associated by the presence of another class I symbol in the same
10619 namespace. 14.6.1.3 of the standard and the discussion on
10620 comp.lang.fortran. */
10621 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10622 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10625 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10626 if (s
&& s
->attr
.generic
)
10627 s
= gfc_find_dt_in_generic (s
);
10628 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10630 gfc_error ("The type '%s' cannot be host associated at %L "
10631 "because it is blocked by an incompatible object "
10632 "of the same name declared at %L",
10633 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10639 /* 4th constraint in section 11.3: "If an object of a type for which
10640 component-initialization is specified (R429) appears in the
10641 specification-part of a module and does not have the ALLOCATABLE
10642 or POINTER attribute, the object shall have the SAVE attribute."
10644 The check for initializers is performed with
10645 gfc_has_default_initializer because gfc_default_initializer generates
10646 a hidden default for allocatable components. */
10647 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10648 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10649 && !sym
->ns
->save_all
&& !sym
->attr
.save
10650 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10651 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10652 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10653 "'%s' at %L, needed due to the default "
10654 "initialization", sym
->name
, &sym
->declared_at
))
10657 /* Assign default initializer. */
10658 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10659 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10661 sym
->value
= gfc_default_initializer (&sym
->ts
);
10668 /* Resolve symbols with flavor variable. */
10671 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10673 int no_init_flag
, automatic_flag
;
10675 const char *auto_save_msg
;
10676 bool saved_specification_expr
;
10678 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10681 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
10684 /* Set this flag to check that variables are parameters of all entries.
10685 This check is effected by the call to gfc_resolve_expr through
10686 is_non_constant_shape_array. */
10687 saved_specification_expr
= specification_expr
;
10688 specification_expr
= true;
10690 if (sym
->ns
->proc_name
10691 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10692 || sym
->ns
->proc_name
->attr
.is_main_program
)
10693 && !sym
->attr
.use_assoc
10694 && !sym
->attr
.allocatable
10695 && !sym
->attr
.pointer
10696 && is_non_constant_shape_array (sym
))
10698 /* The shape of a main program or module array needs to be
10700 gfc_error ("The module or main program array '%s' at %L must "
10701 "have constant shape", sym
->name
, &sym
->declared_at
);
10702 specification_expr
= saved_specification_expr
;
10706 /* Constraints on deferred type parameter. */
10707 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10709 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10710 "requires either the pointer or allocatable attribute",
10711 sym
->name
, &sym
->declared_at
);
10712 specification_expr
= saved_specification_expr
;
10716 if (sym
->ts
.type
== BT_CHARACTER
)
10718 /* Make sure that character string variables with assumed length are
10719 dummy arguments. */
10720 e
= sym
->ts
.u
.cl
->length
;
10721 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10722 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
10724 gfc_error ("Entity with assumed character length at %L must be a "
10725 "dummy argument or a PARAMETER", &sym
->declared_at
);
10726 specification_expr
= saved_specification_expr
;
10730 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10732 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10733 specification_expr
= saved_specification_expr
;
10737 if (!gfc_is_constant_expr (e
)
10738 && !(e
->expr_type
== EXPR_VARIABLE
10739 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10741 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10742 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10743 || sym
->ns
->proc_name
->attr
.is_main_program
))
10745 gfc_error ("'%s' at %L must have constant character length "
10746 "in this context", sym
->name
, &sym
->declared_at
);
10747 specification_expr
= saved_specification_expr
;
10750 if (sym
->attr
.in_common
)
10752 gfc_error ("COMMON variable '%s' at %L must have constant "
10753 "character length", sym
->name
, &sym
->declared_at
);
10754 specification_expr
= saved_specification_expr
;
10760 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10761 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10763 /* Determine if the symbol may not have an initializer. */
10764 no_init_flag
= automatic_flag
= 0;
10765 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10766 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10768 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10769 && is_non_constant_shape_array (sym
))
10771 no_init_flag
= automatic_flag
= 1;
10773 /* Also, they must not have the SAVE attribute.
10774 SAVE_IMPLICIT is checked below. */
10775 if (sym
->as
&& sym
->attr
.codimension
)
10777 int corank
= sym
->as
->corank
;
10778 sym
->as
->corank
= 0;
10779 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10780 sym
->as
->corank
= corank
;
10782 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10784 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10785 specification_expr
= saved_specification_expr
;
10790 /* Ensure that any initializer is simplified. */
10792 gfc_simplify_expr (sym
->value
, 1);
10794 /* Reject illegal initializers. */
10795 if (!sym
->mark
&& sym
->value
)
10797 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10798 && CLASS_DATA (sym
)->attr
.allocatable
))
10799 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10800 sym
->name
, &sym
->declared_at
);
10801 else if (sym
->attr
.external
)
10802 gfc_error ("External '%s' at %L cannot have an initializer",
10803 sym
->name
, &sym
->declared_at
);
10804 else if (sym
->attr
.dummy
10805 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10806 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10807 sym
->name
, &sym
->declared_at
);
10808 else if (sym
->attr
.intrinsic
)
10809 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10810 sym
->name
, &sym
->declared_at
);
10811 else if (sym
->attr
.result
)
10812 gfc_error ("Function result '%s' at %L cannot have an initializer",
10813 sym
->name
, &sym
->declared_at
);
10814 else if (automatic_flag
)
10815 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10816 sym
->name
, &sym
->declared_at
);
10818 goto no_init_error
;
10819 specification_expr
= saved_specification_expr
;
10824 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10826 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10827 specification_expr
= saved_specification_expr
;
10831 specification_expr
= saved_specification_expr
;
10836 /* Resolve a procedure. */
10839 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10841 gfc_formal_arglist
*arg
;
10843 if (sym
->attr
.function
10844 && !resolve_fl_var_and_proc (sym
, mp_flag
))
10847 if (sym
->ts
.type
== BT_CHARACTER
)
10849 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10851 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10852 && !resolve_charlen (cl
))
10855 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10856 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10858 gfc_error ("Character-valued statement function '%s' at %L must "
10859 "have constant length", sym
->name
, &sym
->declared_at
);
10864 /* Ensure that derived type for are not of a private type. Internal
10865 module procedures are excluded by 2.2.3.3 - i.e., they are not
10866 externally accessible and can access all the objects accessible in
10868 if (!(sym
->ns
->parent
10869 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10870 && gfc_check_symbol_access (sym
))
10872 gfc_interface
*iface
;
10874 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
10877 && arg
->sym
->ts
.type
== BT_DERIVED
10878 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10879 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10880 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
10881 "and cannot be a dummy argument"
10882 " of '%s', which is PUBLIC at %L",
10883 arg
->sym
->name
, sym
->name
,
10884 &sym
->declared_at
))
10886 /* Stop this message from recurring. */
10887 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10892 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10893 PRIVATE to the containing module. */
10894 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10896 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10899 && arg
->sym
->ts
.type
== BT_DERIVED
10900 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10901 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10902 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10903 "PUBLIC interface '%s' at %L "
10904 "takes dummy arguments of '%s' which "
10905 "is PRIVATE", iface
->sym
->name
,
10906 sym
->name
, &iface
->sym
->declared_at
,
10907 gfc_typename(&arg
->sym
->ts
)))
10909 /* Stop this message from recurring. */
10910 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10916 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10917 PRIVATE to the containing module. */
10918 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10920 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10923 && arg
->sym
->ts
.type
== BT_DERIVED
10924 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10925 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10926 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10927 "PUBLIC interface '%s' at %L takes "
10928 "dummy arguments of '%s' which is "
10929 "PRIVATE", iface
->sym
->name
,
10930 sym
->name
, &iface
->sym
->declared_at
,
10931 gfc_typename(&arg
->sym
->ts
)))
10933 /* Stop this message from recurring. */
10934 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10941 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10942 && !sym
->attr
.proc_pointer
)
10944 gfc_error ("Function '%s' at %L cannot have an initializer",
10945 sym
->name
, &sym
->declared_at
);
10949 /* An external symbol may not have an initializer because it is taken to be
10950 a procedure. Exception: Procedure Pointers. */
10951 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10953 gfc_error ("External object '%s' at %L may not have an initializer",
10954 sym
->name
, &sym
->declared_at
);
10958 /* An elemental function is required to return a scalar 12.7.1 */
10959 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10961 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10962 "result", sym
->name
, &sym
->declared_at
);
10963 /* Reset so that the error only occurs once. */
10964 sym
->attr
.elemental
= 0;
10968 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10969 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10971 gfc_error ("Statement function '%s' at %L may not have pointer or "
10972 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10976 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10977 char-len-param shall not be array-valued, pointer-valued, recursive
10978 or pure. ....snip... A character value of * may only be used in the
10979 following ways: (i) Dummy arg of procedure - dummy associates with
10980 actual length; (ii) To declare a named constant; or (iii) External
10981 function - but length must be declared in calling scoping unit. */
10982 if (sym
->attr
.function
10983 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
10984 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10986 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10987 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10989 if (sym
->as
&& sym
->as
->rank
)
10990 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10991 "array-valued", sym
->name
, &sym
->declared_at
);
10993 if (sym
->attr
.pointer
)
10994 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10995 "pointer-valued", sym
->name
, &sym
->declared_at
);
10997 if (sym
->attr
.pure
)
10998 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10999 "pure", sym
->name
, &sym
->declared_at
);
11001 if (sym
->attr
.recursive
)
11002 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11003 "recursive", sym
->name
, &sym
->declared_at
);
11008 /* Appendix B.2 of the standard. Contained functions give an
11009 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11010 character length is an F2003 feature. */
11011 if (!sym
->attr
.contained
11012 && gfc_current_form
!= FORM_FIXED
11013 && !sym
->ts
.deferred
)
11014 gfc_notify_std (GFC_STD_F95_OBS
,
11015 "CHARACTER(*) function '%s' at %L",
11016 sym
->name
, &sym
->declared_at
);
11019 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11021 gfc_formal_arglist
*curr_arg
;
11022 int has_non_interop_arg
= 0;
11024 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11025 sym
->common_block
))
11027 /* Clear these to prevent looking at them again if there was an
11029 sym
->attr
.is_bind_c
= 0;
11030 sym
->attr
.is_c_interop
= 0;
11031 sym
->ts
.is_c_interop
= 0;
11035 /* So far, no errors have been found. */
11036 sym
->attr
.is_c_interop
= 1;
11037 sym
->ts
.is_c_interop
= 1;
11040 curr_arg
= gfc_sym_get_dummy_args (sym
);
11041 while (curr_arg
!= NULL
)
11043 /* Skip implicitly typed dummy args here. */
11044 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11045 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11046 /* If something is found to fail, record the fact so we
11047 can mark the symbol for the procedure as not being
11048 BIND(C) to try and prevent multiple errors being
11050 has_non_interop_arg
= 1;
11052 curr_arg
= curr_arg
->next
;
11055 /* See if any of the arguments were not interoperable and if so, clear
11056 the procedure symbol to prevent duplicate error messages. */
11057 if (has_non_interop_arg
!= 0)
11059 sym
->attr
.is_c_interop
= 0;
11060 sym
->ts
.is_c_interop
= 0;
11061 sym
->attr
.is_bind_c
= 0;
11065 if (!sym
->attr
.proc_pointer
)
11067 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11069 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11070 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11073 if (sym
->attr
.intent
)
11075 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11076 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11079 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11081 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11082 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11085 if (sym
->attr
.external
&& sym
->attr
.function
11086 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11087 || sym
->attr
.contained
))
11089 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11090 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11093 if (strcmp ("ppr@", sym
->name
) == 0)
11095 gfc_error ("Procedure pointer result '%s' at %L "
11096 "is missing the pointer attribute",
11097 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11106 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11107 been defined and we now know their defined arguments, check that they fulfill
11108 the requirements of the standard for procedures used as finalizers. */
11111 gfc_resolve_finalizers (gfc_symbol
* derived
)
11113 gfc_finalizer
* list
;
11114 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11115 bool result
= true;
11116 bool seen_scalar
= false;
11118 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11121 /* Walk over the list of finalizer-procedures, check them, and if any one
11122 does not fit in with the standard's definition, print an error and remove
11123 it from the list. */
11124 prev_link
= &derived
->f2k_derived
->finalizers
;
11125 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11127 gfc_formal_arglist
*dummy_args
;
11132 /* Skip this finalizer if we already resolved it. */
11133 if (list
->proc_tree
)
11135 prev_link
= &(list
->next
);
11139 /* Check this exists and is a SUBROUTINE. */
11140 if (!list
->proc_sym
->attr
.subroutine
)
11142 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11143 list
->proc_sym
->name
, &list
->where
);
11147 /* We should have exactly one argument. */
11148 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11149 if (!dummy_args
|| dummy_args
->next
)
11151 gfc_error ("FINAL procedure at %L must have exactly one argument",
11155 arg
= dummy_args
->sym
;
11157 /* This argument must be of our type. */
11158 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11160 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11161 &arg
->declared_at
, derived
->name
);
11165 /* It must neither be a pointer nor allocatable nor optional. */
11166 if (arg
->attr
.pointer
)
11168 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11169 &arg
->declared_at
);
11172 if (arg
->attr
.allocatable
)
11174 gfc_error ("Argument of FINAL procedure at %L must not be"
11175 " ALLOCATABLE", &arg
->declared_at
);
11178 if (arg
->attr
.optional
)
11180 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11181 &arg
->declared_at
);
11185 /* It must not be INTENT(OUT). */
11186 if (arg
->attr
.intent
== INTENT_OUT
)
11188 gfc_error ("Argument of FINAL procedure at %L must not be"
11189 " INTENT(OUT)", &arg
->declared_at
);
11193 /* Warn if the procedure is non-scalar and not assumed shape. */
11194 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11195 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11196 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11197 " shape argument", &arg
->declared_at
);
11199 /* Check that it does not match in kind and rank with a FINAL procedure
11200 defined earlier. To really loop over the *earlier* declarations,
11201 we need to walk the tail of the list as new ones were pushed at the
11203 /* TODO: Handle kind parameters once they are implemented. */
11204 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11205 for (i
= list
->next
; i
; i
= i
->next
)
11207 gfc_formal_arglist
*dummy_args
;
11209 /* Argument list might be empty; that is an error signalled earlier,
11210 but we nevertheless continued resolving. */
11211 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11214 gfc_symbol
* i_arg
= dummy_args
->sym
;
11215 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11216 if (i_rank
== my_rank
)
11218 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11219 " rank (%d) as '%s'",
11220 list
->proc_sym
->name
, &list
->where
, my_rank
,
11221 i
->proc_sym
->name
);
11227 /* Is this the/a scalar finalizer procedure? */
11228 if (!arg
->as
|| arg
->as
->rank
== 0)
11229 seen_scalar
= true;
11231 /* Find the symtree for this procedure. */
11232 gcc_assert (!list
->proc_tree
);
11233 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11235 prev_link
= &list
->next
;
11238 /* Remove wrong nodes immediately from the list so we don't risk any
11239 troubles in the future when they might fail later expectations. */
11243 *prev_link
= list
->next
;
11244 gfc_free_finalizer (i
);
11247 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11248 were nodes in the list, must have been for arrays. It is surely a good
11249 idea to have a scalar version there if there's something to finalize. */
11250 if (gfc_option
.warn_surprising
&& result
&& !seen_scalar
)
11251 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11252 " defined at %L, suggest also scalar one",
11253 derived
->name
, &derived
->declared_at
);
11255 gfc_find_derived_vtab (derived
);
11260 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11263 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11264 const char* generic_name
, locus where
)
11266 gfc_symbol
*sym1
, *sym2
;
11267 const char *pass1
, *pass2
;
11269 gcc_assert (t1
->specific
&& t2
->specific
);
11270 gcc_assert (!t1
->specific
->is_generic
);
11271 gcc_assert (!t2
->specific
->is_generic
);
11272 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11274 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11275 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11280 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11281 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11282 || sym1
->attr
.function
!= sym2
->attr
.function
)
11284 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11285 " GENERIC '%s' at %L",
11286 sym1
->name
, sym2
->name
, generic_name
, &where
);
11290 /* Compare the interfaces. */
11291 if (t1
->specific
->nopass
)
11293 else if (t1
->specific
->pass_arg
)
11294 pass1
= t1
->specific
->pass_arg
;
11296 pass1
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11297 if (t2
->specific
->nopass
)
11299 else if (t2
->specific
->pass_arg
)
11300 pass2
= t2
->specific
->pass_arg
;
11302 pass2
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11303 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11304 NULL
, 0, pass1
, pass2
))
11306 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11307 sym1
->name
, sym2
->name
, generic_name
, &where
);
11315 /* Worker function for resolving a generic procedure binding; this is used to
11316 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11318 The difference between those cases is finding possible inherited bindings
11319 that are overridden, as one has to look for them in tb_sym_root,
11320 tb_uop_root or tb_op, respectively. Thus the caller must already find
11321 the super-type and set p->overridden correctly. */
11324 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11325 gfc_typebound_proc
* p
, const char* name
)
11327 gfc_tbp_generic
* target
;
11328 gfc_symtree
* first_target
;
11329 gfc_symtree
* inherited
;
11331 gcc_assert (p
&& p
->is_generic
);
11333 /* Try to find the specific bindings for the symtrees in our target-list. */
11334 gcc_assert (p
->u
.generic
);
11335 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11336 if (!target
->specific
)
11338 gfc_typebound_proc
* overridden_tbp
;
11339 gfc_tbp_generic
* g
;
11340 const char* target_name
;
11342 target_name
= target
->specific_st
->name
;
11344 /* Defined for this type directly. */
11345 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11347 target
->specific
= target
->specific_st
->n
.tb
;
11348 goto specific_found
;
11351 /* Look for an inherited specific binding. */
11354 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11359 gcc_assert (inherited
->n
.tb
);
11360 target
->specific
= inherited
->n
.tb
;
11361 goto specific_found
;
11365 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11366 " at %L", target_name
, name
, &p
->where
);
11369 /* Once we've found the specific binding, check it is not ambiguous with
11370 other specifics already found or inherited for the same GENERIC. */
11372 gcc_assert (target
->specific
);
11374 /* This must really be a specific binding! */
11375 if (target
->specific
->is_generic
)
11377 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11378 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11382 /* Check those already resolved on this type directly. */
11383 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11384 if (g
!= target
&& g
->specific
11385 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11388 /* Check for ambiguity with inherited specific targets. */
11389 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11390 overridden_tbp
= overridden_tbp
->overridden
)
11391 if (overridden_tbp
->is_generic
)
11393 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11395 gcc_assert (g
->specific
);
11396 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11402 /* If we attempt to "overwrite" a specific binding, this is an error. */
11403 if (p
->overridden
&& !p
->overridden
->is_generic
)
11405 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11406 " the same name", name
, &p
->where
);
11410 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11411 all must have the same attributes here. */
11412 first_target
= p
->u
.generic
->specific
->u
.specific
;
11413 gcc_assert (first_target
);
11414 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11415 p
->function
= first_target
->n
.sym
->attr
.function
;
11421 /* Resolve a GENERIC procedure binding for a derived type. */
11424 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11426 gfc_symbol
* super_type
;
11428 /* Find the overridden binding if any. */
11429 st
->n
.tb
->overridden
= NULL
;
11430 super_type
= gfc_get_derived_super_type (derived
);
11433 gfc_symtree
* overridden
;
11434 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11437 if (overridden
&& overridden
->n
.tb
)
11438 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11441 /* Resolve using worker function. */
11442 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11446 /* Retrieve the target-procedure of an operator binding and do some checks in
11447 common for intrinsic and user-defined type-bound operators. */
11450 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11452 gfc_symbol
* target_proc
;
11454 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11455 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11456 gcc_assert (target_proc
);
11458 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11459 if (target
->specific
->nopass
)
11461 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11465 return target_proc
;
11469 /* Resolve a type-bound intrinsic operator. */
11472 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11473 gfc_typebound_proc
* p
)
11475 gfc_symbol
* super_type
;
11476 gfc_tbp_generic
* target
;
11478 /* If there's already an error here, do nothing (but don't fail again). */
11482 /* Operators should always be GENERIC bindings. */
11483 gcc_assert (p
->is_generic
);
11485 /* Look for an overridden binding. */
11486 super_type
= gfc_get_derived_super_type (derived
);
11487 if (super_type
&& super_type
->f2k_derived
)
11488 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11491 p
->overridden
= NULL
;
11493 /* Resolve general GENERIC properties using worker function. */
11494 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11497 /* Check the targets to be procedures of correct interface. */
11498 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11500 gfc_symbol
* target_proc
;
11502 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11506 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11509 /* Add target to non-typebound operator list. */
11510 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11511 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11513 gfc_interface
*head
, *intr
;
11514 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11516 head
= derived
->ns
->op
[op
];
11517 intr
= gfc_get_interface ();
11518 intr
->sym
= target_proc
;
11519 intr
->where
= p
->where
;
11521 derived
->ns
->op
[op
] = intr
;
11533 /* Resolve a type-bound user operator (tree-walker callback). */
11535 static gfc_symbol
* resolve_bindings_derived
;
11536 static bool resolve_bindings_result
;
11538 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11541 resolve_typebound_user_op (gfc_symtree
* stree
)
11543 gfc_symbol
* super_type
;
11544 gfc_tbp_generic
* target
;
11546 gcc_assert (stree
&& stree
->n
.tb
);
11548 if (stree
->n
.tb
->error
)
11551 /* Operators should always be GENERIC bindings. */
11552 gcc_assert (stree
->n
.tb
->is_generic
);
11554 /* Find overridden procedure, if any. */
11555 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11556 if (super_type
&& super_type
->f2k_derived
)
11558 gfc_symtree
* overridden
;
11559 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11560 stree
->name
, true, NULL
);
11562 if (overridden
&& overridden
->n
.tb
)
11563 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11566 stree
->n
.tb
->overridden
= NULL
;
11568 /* Resolve basically using worker function. */
11569 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11572 /* Check the targets to be functions of correct interface. */
11573 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11575 gfc_symbol
* target_proc
;
11577 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11581 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11588 resolve_bindings_result
= false;
11589 stree
->n
.tb
->error
= 1;
11593 /* Resolve the type-bound procedures for a derived type. */
11596 resolve_typebound_procedure (gfc_symtree
* stree
)
11600 gfc_symbol
* me_arg
;
11601 gfc_symbol
* super_type
;
11602 gfc_component
* comp
;
11604 gcc_assert (stree
);
11606 /* Undefined specific symbol from GENERIC target definition. */
11610 if (stree
->n
.tb
->error
)
11613 /* If this is a GENERIC binding, use that routine. */
11614 if (stree
->n
.tb
->is_generic
)
11616 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11621 /* Get the target-procedure to check it. */
11622 gcc_assert (!stree
->n
.tb
->is_generic
);
11623 gcc_assert (stree
->n
.tb
->u
.specific
);
11624 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11625 where
= stree
->n
.tb
->where
;
11627 /* Default access should already be resolved from the parser. */
11628 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11630 if (stree
->n
.tb
->deferred
)
11632 if (!check_proc_interface (proc
, &where
))
11637 /* Check for F08:C465. */
11638 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11639 || (proc
->attr
.proc
!= PROC_MODULE
11640 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11641 || proc
->attr
.abstract
)
11643 gfc_error ("'%s' must be a module procedure or an external procedure with"
11644 " an explicit interface at %L", proc
->name
, &where
);
11649 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11650 stree
->n
.tb
->function
= proc
->attr
.function
;
11652 /* Find the super-type of the current derived type. We could do this once and
11653 store in a global if speed is needed, but as long as not I believe this is
11654 more readable and clearer. */
11655 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11657 /* If PASS, resolve and check arguments if not already resolved / loaded
11658 from a .mod file. */
11659 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11661 gfc_formal_arglist
*dummy_args
;
11663 dummy_args
= gfc_sym_get_dummy_args (proc
);
11664 if (stree
->n
.tb
->pass_arg
)
11666 gfc_formal_arglist
*i
;
11668 /* If an explicit passing argument name is given, walk the arg-list
11669 and look for it. */
11672 stree
->n
.tb
->pass_arg_num
= 1;
11673 for (i
= dummy_args
; i
; i
= i
->next
)
11675 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11680 ++stree
->n
.tb
->pass_arg_num
;
11685 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11687 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11688 stree
->n
.tb
->pass_arg
);
11694 /* Otherwise, take the first one; there should in fact be at least
11696 stree
->n
.tb
->pass_arg_num
= 1;
11699 gfc_error ("Procedure '%s' with PASS at %L must have at"
11700 " least one argument", proc
->name
, &where
);
11703 me_arg
= dummy_args
->sym
;
11706 /* Now check that the argument-type matches and the passed-object
11707 dummy argument is generally fine. */
11709 gcc_assert (me_arg
);
11711 if (me_arg
->ts
.type
!= BT_CLASS
)
11713 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11714 " at %L", proc
->name
, &where
);
11718 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11719 != resolve_bindings_derived
)
11721 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11722 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11723 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11727 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11728 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11730 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11731 " scalar", proc
->name
, &where
);
11734 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11736 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11737 " be ALLOCATABLE", proc
->name
, &where
);
11740 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11742 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11743 " be POINTER", proc
->name
, &where
);
11748 /* If we are extending some type, check that we don't override a procedure
11749 flagged NON_OVERRIDABLE. */
11750 stree
->n
.tb
->overridden
= NULL
;
11753 gfc_symtree
* overridden
;
11754 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11755 stree
->name
, true, NULL
);
11759 if (overridden
->n
.tb
)
11760 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11762 if (!gfc_check_typebound_override (stree
, overridden
))
11767 /* See if there's a name collision with a component directly in this type. */
11768 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11769 if (!strcmp (comp
->name
, stree
->name
))
11771 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11773 stree
->name
, &where
, resolve_bindings_derived
->name
);
11777 /* Try to find a name collision with an inherited component. */
11778 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11780 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11781 " component of '%s'",
11782 stree
->name
, &where
, resolve_bindings_derived
->name
);
11786 stree
->n
.tb
->error
= 0;
11790 resolve_bindings_result
= false;
11791 stree
->n
.tb
->error
= 1;
11796 resolve_typebound_procedures (gfc_symbol
* derived
)
11799 gfc_symbol
* super_type
;
11801 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11804 super_type
= gfc_get_derived_super_type (derived
);
11806 resolve_symbol (super_type
);
11808 resolve_bindings_derived
= derived
;
11809 resolve_bindings_result
= true;
11811 /* Make sure the vtab has been generated. */
11812 gfc_find_derived_vtab (derived
);
11814 if (derived
->f2k_derived
->tb_sym_root
)
11815 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11816 &resolve_typebound_procedure
);
11818 if (derived
->f2k_derived
->tb_uop_root
)
11819 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11820 &resolve_typebound_user_op
);
11822 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11824 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11825 if (p
&& !resolve_typebound_intrinsic_op (derived
,
11826 (gfc_intrinsic_op
)op
, p
))
11827 resolve_bindings_result
= false;
11830 return resolve_bindings_result
;
11834 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11835 to give all identical derived types the same backend_decl. */
11837 add_dt_to_dt_list (gfc_symbol
*derived
)
11839 gfc_dt_list
*dt_list
;
11841 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11842 if (derived
== dt_list
->derived
)
11845 dt_list
= gfc_get_dt_list ();
11846 dt_list
->next
= gfc_derived_types
;
11847 dt_list
->derived
= derived
;
11848 gfc_derived_types
= dt_list
;
11852 /* Ensure that a derived-type is really not abstract, meaning that every
11853 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11856 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11861 if (!ensure_not_abstract_walker (sub
, st
->left
))
11863 if (!ensure_not_abstract_walker (sub
, st
->right
))
11866 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11868 gfc_symtree
* overriding
;
11869 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11872 gcc_assert (overriding
->n
.tb
);
11873 if (overriding
->n
.tb
->deferred
)
11875 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11876 " '%s' is DEFERRED and not overridden",
11877 sub
->name
, &sub
->declared_at
, st
->name
);
11886 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11888 /* The algorithm used here is to recursively travel up the ancestry of sub
11889 and for each ancestor-type, check all bindings. If any of them is
11890 DEFERRED, look it up starting from sub and see if the found (overriding)
11891 binding is not DEFERRED.
11892 This is not the most efficient way to do this, but it should be ok and is
11893 clearer than something sophisticated. */
11895 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11897 if (!ancestor
->attr
.abstract
)
11900 /* Walk bindings of this ancestor. */
11901 if (ancestor
->f2k_derived
)
11904 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11909 /* Find next ancestor type and recurse on it. */
11910 ancestor
= gfc_get_derived_super_type (ancestor
);
11912 return ensure_not_abstract (sub
, ancestor
);
11918 /* This check for typebound defined assignments is done recursively
11919 since the order in which derived types are resolved is not always in
11920 order of the declarations. */
11923 check_defined_assignments (gfc_symbol
*derived
)
11927 for (c
= derived
->components
; c
; c
= c
->next
)
11929 if (c
->ts
.type
!= BT_DERIVED
11931 || c
->attr
.allocatable
11932 || c
->attr
.proc_pointer_comp
11933 || c
->attr
.class_pointer
11934 || c
->attr
.proc_pointer
)
11937 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
11938 || (c
->ts
.u
.derived
->f2k_derived
11939 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
11941 derived
->attr
.defined_assign_comp
= 1;
11945 check_defined_assignments (c
->ts
.u
.derived
);
11946 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
11948 derived
->attr
.defined_assign_comp
= 1;
11955 /* Resolve the components of a derived type. This does not have to wait until
11956 resolution stage, but can be done as soon as the dt declaration has been
11960 resolve_fl_derived0 (gfc_symbol
*sym
)
11962 gfc_symbol
* super_type
;
11965 if (sym
->attr
.unlimited_polymorphic
)
11968 super_type
= gfc_get_derived_super_type (sym
);
11971 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11973 gfc_error ("As extending type '%s' at %L has a coarray component, "
11974 "parent type '%s' shall also have one", sym
->name
,
11975 &sym
->declared_at
, super_type
->name
);
11979 /* Ensure the extended type gets resolved before we do. */
11980 if (super_type
&& !resolve_fl_derived0 (super_type
))
11983 /* An ABSTRACT type must be extensible. */
11984 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11986 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11987 sym
->name
, &sym
->declared_at
);
11991 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11994 for ( ; c
!= NULL
; c
= c
->next
)
11996 if (c
->attr
.artificial
)
11999 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12000 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
12002 gfc_error ("Deferred-length character component '%s' at %L is not "
12003 "yet supported", c
->name
, &c
->loc
);
12008 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12009 && c
->attr
.codimension
12010 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12012 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12013 "deferred shape", c
->name
, &c
->loc
);
12018 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12019 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12021 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12022 "shall not be a coarray", c
->name
, &c
->loc
);
12027 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12028 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12029 || c
->attr
.allocatable
))
12031 gfc_error ("Component '%s' at %L with coarray component "
12032 "shall be a nonpointer, nonallocatable scalar",
12038 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12040 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12041 "is not an array pointer", c
->name
, &c
->loc
);
12045 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12047 gfc_symbol
*ifc
= c
->ts
.interface
;
12049 if (!sym
->attr
.vtype
12050 && !check_proc_interface (ifc
, &c
->loc
))
12053 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12055 /* Resolve interface and copy attributes. */
12056 if (ifc
->formal
&& !ifc
->formal_ns
)
12057 resolve_symbol (ifc
);
12058 if (ifc
->attr
.intrinsic
)
12059 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12063 c
->ts
= ifc
->result
->ts
;
12064 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12065 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12066 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12067 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12068 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12073 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12074 c
->attr
.pointer
= ifc
->attr
.pointer
;
12075 c
->attr
.dimension
= ifc
->attr
.dimension
;
12076 c
->as
= gfc_copy_array_spec (ifc
->as
);
12077 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12079 c
->ts
.interface
= ifc
;
12080 c
->attr
.function
= ifc
->attr
.function
;
12081 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12083 c
->attr
.pure
= ifc
->attr
.pure
;
12084 c
->attr
.elemental
= ifc
->attr
.elemental
;
12085 c
->attr
.recursive
= ifc
->attr
.recursive
;
12086 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12087 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12088 /* Copy char length. */
12089 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12091 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12092 if (cl
->length
&& !cl
->resolved
12093 && !gfc_resolve_expr (cl
->length
))
12099 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12101 /* Since PPCs are not implicitly typed, a PPC without an explicit
12102 interface must be a subroutine. */
12103 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12106 /* Procedure pointer components: Check PASS arg. */
12107 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12108 && !sym
->attr
.vtype
)
12110 gfc_symbol
* me_arg
;
12112 if (c
->tb
->pass_arg
)
12114 gfc_formal_arglist
* i
;
12116 /* If an explicit passing argument name is given, walk the arg-list
12117 and look for it. */
12120 c
->tb
->pass_arg_num
= 1;
12121 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12123 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12128 c
->tb
->pass_arg_num
++;
12133 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12134 "at %L has no argument '%s'", c
->name
,
12135 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12142 /* Otherwise, take the first one; there should in fact be at least
12144 c
->tb
->pass_arg_num
= 1;
12145 if (!c
->ts
.interface
->formal
)
12147 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12148 "must have at least one argument",
12153 me_arg
= c
->ts
.interface
->formal
->sym
;
12156 /* Now check that the argument-type matches. */
12157 gcc_assert (me_arg
);
12158 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12159 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12160 || (me_arg
->ts
.type
== BT_CLASS
12161 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12163 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12164 " the derived type '%s'", me_arg
->name
, c
->name
,
12165 me_arg
->name
, &c
->loc
, sym
->name
);
12170 /* Check for C453. */
12171 if (me_arg
->attr
.dimension
)
12173 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12174 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12180 if (me_arg
->attr
.pointer
)
12182 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12183 "may not have the POINTER attribute", me_arg
->name
,
12184 c
->name
, me_arg
->name
, &c
->loc
);
12189 if (me_arg
->attr
.allocatable
)
12191 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12192 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12193 me_arg
->name
, &c
->loc
);
12198 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12199 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12200 " at %L", c
->name
, &c
->loc
);
12204 /* Check type-spec if this is not the parent-type component. */
12205 if (((sym
->attr
.is_class
12206 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12207 || c
!= sym
->components
->ts
.u
.derived
->components
))
12208 || (!sym
->attr
.is_class
12209 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12210 && !sym
->attr
.vtype
12211 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12214 /* If this type is an extension, set the accessibility of the parent
12217 && ((sym
->attr
.is_class
12218 && c
== sym
->components
->ts
.u
.derived
->components
)
12219 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12220 && strcmp (super_type
->name
, c
->name
) == 0)
12221 c
->attr
.access
= super_type
->attr
.access
;
12223 /* If this type is an extension, see if this component has the same name
12224 as an inherited type-bound procedure. */
12225 if (super_type
&& !sym
->attr
.is_class
12226 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12228 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12229 " inherited type-bound procedure",
12230 c
->name
, sym
->name
, &c
->loc
);
12234 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12235 && !c
->ts
.deferred
)
12237 if (c
->ts
.u
.cl
->length
== NULL
12238 || (!resolve_charlen(c
->ts
.u
.cl
))
12239 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12241 gfc_error ("Character length of component '%s' needs to "
12242 "be a constant specification expression at %L",
12244 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12249 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12250 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12252 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12253 "length must be a POINTER or ALLOCATABLE",
12254 c
->name
, sym
->name
, &c
->loc
);
12258 if (c
->ts
.type
== BT_DERIVED
12259 && sym
->component_access
!= ACCESS_PRIVATE
12260 && gfc_check_symbol_access (sym
)
12261 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12262 && !c
->ts
.u
.derived
->attr
.use_assoc
12263 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12264 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12265 "PRIVATE type and cannot be a component of "
12266 "'%s', which is PUBLIC at %L", c
->name
,
12267 sym
->name
, &sym
->declared_at
))
12270 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12272 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12273 "type %s", c
->name
, &c
->loc
, sym
->name
);
12277 if (sym
->attr
.sequence
)
12279 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12281 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12282 "not have the SEQUENCE attribute",
12283 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12288 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12289 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12290 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12291 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12292 CLASS_DATA (c
)->ts
.u
.derived
12293 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12295 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12296 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12297 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12299 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12300 "that has not been declared", c
->name
, sym
->name
,
12305 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12306 && CLASS_DATA (c
)->attr
.class_pointer
12307 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12308 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12309 && !UNLIMITED_POLY (c
))
12311 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12312 "that has not been declared", c
->name
, sym
->name
,
12318 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12319 && (!c
->attr
.class_ok
12320 || !(CLASS_DATA (c
)->attr
.class_pointer
12321 || CLASS_DATA (c
)->attr
.allocatable
)))
12323 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12324 "or pointer", c
->name
, &c
->loc
);
12325 /* Prevent a recurrence of the error. */
12326 c
->ts
.type
= BT_UNKNOWN
;
12330 /* Ensure that all the derived type components are put on the
12331 derived type list; even in formal namespaces, where derived type
12332 pointer components might not have been declared. */
12333 if (c
->ts
.type
== BT_DERIVED
12335 && c
->ts
.u
.derived
->components
12337 && sym
!= c
->ts
.u
.derived
)
12338 add_dt_to_dt_list (c
->ts
.u
.derived
);
12340 if (!gfc_resolve_array_spec (c
->as
,
12341 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12342 || c
->attr
.allocatable
)))
12345 if (c
->initializer
&& !sym
->attr
.vtype
12346 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12350 check_defined_assignments (sym
);
12352 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12353 sym
->attr
.defined_assign_comp
12354 = super_type
->attr
.defined_assign_comp
;
12356 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12357 all DEFERRED bindings are overridden. */
12358 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12359 && !sym
->attr
.is_class
12360 && !ensure_not_abstract (sym
, super_type
))
12363 /* Add derived type to the derived type list. */
12364 add_dt_to_dt_list (sym
);
12366 /* Check if the type is finalizable. This is done in order to ensure that the
12367 finalization wrapper is generated early enough. */
12368 gfc_is_finalizable (sym
, NULL
);
12374 /* The following procedure does the full resolution of a derived type,
12375 including resolution of all type-bound procedures (if present). In contrast
12376 to 'resolve_fl_derived0' this can only be done after the module has been
12377 parsed completely. */
12380 resolve_fl_derived (gfc_symbol
*sym
)
12382 gfc_symbol
*gen_dt
= NULL
;
12384 if (sym
->attr
.unlimited_polymorphic
)
12387 if (!sym
->attr
.is_class
)
12388 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12389 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12390 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12391 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12392 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12393 "'%s' at %L being the same name as derived "
12394 "type at %L", sym
->name
,
12395 gen_dt
->generic
->sym
== sym
12396 ? gen_dt
->generic
->next
->sym
->name
12397 : gen_dt
->generic
->sym
->name
,
12398 gen_dt
->generic
->sym
== sym
12399 ? &gen_dt
->generic
->next
->sym
->declared_at
12400 : &gen_dt
->generic
->sym
->declared_at
,
12401 &sym
->declared_at
))
12404 /* Resolve the finalizer procedures. */
12405 if (!gfc_resolve_finalizers (sym
))
12408 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12410 /* Fix up incomplete CLASS symbols. */
12411 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12412 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12414 /* Nothing more to do for unlimited polymorphic entities. */
12415 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12417 else if (vptr
->ts
.u
.derived
== NULL
)
12419 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12421 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12425 if (!resolve_fl_derived0 (sym
))
12428 /* Resolve the type-bound procedures. */
12429 if (!resolve_typebound_procedures (sym
))
12437 resolve_fl_namelist (gfc_symbol
*sym
)
12442 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12444 /* Check again, the check in match only works if NAMELIST comes
12446 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12448 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12449 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12453 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12454 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12455 "with assumed shape in namelist '%s' at %L",
12456 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12459 if (is_non_constant_shape_array (nl
->sym
)
12460 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12461 "with nonconstant shape in namelist '%s' at %L",
12462 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12465 if (nl
->sym
->ts
.type
== BT_CHARACTER
12466 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12467 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12468 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12469 "nonconstant character length in "
12470 "namelist '%s' at %L", nl
->sym
->name
,
12471 sym
->name
, &sym
->declared_at
))
12474 /* FIXME: Once UDDTIO is implemented, the following can be
12476 if (nl
->sym
->ts
.type
== BT_CLASS
)
12478 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12479 "polymorphic and requires a defined input/output "
12480 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12484 if (nl
->sym
->ts
.type
== BT_DERIVED
12485 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12486 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12488 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12489 "namelist '%s' at %L with ALLOCATABLE "
12490 "or POINTER components", nl
->sym
->name
,
12491 sym
->name
, &sym
->declared_at
))
12494 /* FIXME: Once UDDTIO is implemented, the following can be
12496 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12497 "ALLOCATABLE or POINTER components and thus requires "
12498 "a defined input/output procedure", nl
->sym
->name
,
12499 sym
->name
, &sym
->declared_at
);
12504 /* Reject PRIVATE objects in a PUBLIC namelist. */
12505 if (gfc_check_symbol_access (sym
))
12507 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12509 if (!nl
->sym
->attr
.use_assoc
12510 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12511 && !gfc_check_symbol_access (nl
->sym
))
12513 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12514 "cannot be member of PUBLIC namelist '%s' at %L",
12515 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12519 /* Types with private components that came here by USE-association. */
12520 if (nl
->sym
->ts
.type
== BT_DERIVED
12521 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12523 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12524 "components and cannot be member of namelist '%s' at %L",
12525 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12529 /* Types with private components that are defined in the same module. */
12530 if (nl
->sym
->ts
.type
== BT_DERIVED
12531 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12532 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12534 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12535 "cannot be a member of PUBLIC namelist '%s' at %L",
12536 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12543 /* 14.1.2 A module or internal procedure represent local entities
12544 of the same type as a namelist member and so are not allowed. */
12545 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12547 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12550 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12551 if ((nl
->sym
== sym
->ns
->proc_name
)
12553 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12558 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12559 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12561 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12562 "attribute in '%s' at %L", nlsym
->name
,
12563 &sym
->declared_at
);
12573 resolve_fl_parameter (gfc_symbol
*sym
)
12575 /* A parameter array's shape needs to be constant. */
12576 if (sym
->as
!= NULL
12577 && (sym
->as
->type
== AS_DEFERRED
12578 || is_non_constant_shape_array (sym
)))
12580 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12581 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12585 /* Make sure a parameter that has been implicitly typed still
12586 matches the implicit type, since PARAMETER statements can precede
12587 IMPLICIT statements. */
12588 if (sym
->attr
.implicit_type
12589 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12592 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12593 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12597 /* Make sure the types of derived parameters are consistent. This
12598 type checking is deferred until resolution because the type may
12599 refer to a derived type from the host. */
12600 if (sym
->ts
.type
== BT_DERIVED
12601 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12603 gfc_error ("Incompatible derived type in PARAMETER at %L",
12604 &sym
->value
->where
);
12611 /* Do anything necessary to resolve a symbol. Right now, we just
12612 assume that an otherwise unknown symbol is a variable. This sort
12613 of thing commonly happens for symbols in module. */
12616 resolve_symbol (gfc_symbol
*sym
)
12618 int check_constant
, mp_flag
;
12619 gfc_symtree
*symtree
;
12620 gfc_symtree
*this_symtree
;
12623 symbol_attribute class_attr
;
12624 gfc_array_spec
*as
;
12625 bool saved_specification_expr
;
12631 if (sym
->attr
.artificial
)
12634 if (sym
->attr
.unlimited_polymorphic
)
12637 if (sym
->attr
.flavor
== FL_UNKNOWN
12638 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12639 && !sym
->attr
.generic
&& !sym
->attr
.external
12640 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12643 /* If we find that a flavorless symbol is an interface in one of the
12644 parent namespaces, find its symtree in this namespace, free the
12645 symbol and set the symtree to point to the interface symbol. */
12646 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12648 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12649 if (symtree
&& (symtree
->n
.sym
->generic
||
12650 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12651 && sym
->ns
->construct_entities
)))
12653 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12655 gfc_release_symbol (sym
);
12656 symtree
->n
.sym
->refs
++;
12657 this_symtree
->n
.sym
= symtree
->n
.sym
;
12662 /* Otherwise give it a flavor according to such attributes as
12664 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12665 && sym
->attr
.intrinsic
== 0)
12666 sym
->attr
.flavor
= FL_VARIABLE
;
12667 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12669 sym
->attr
.flavor
= FL_PROCEDURE
;
12670 if (sym
->attr
.dimension
)
12671 sym
->attr
.function
= 1;
12675 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12676 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12678 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12679 && !resolve_procedure_interface (sym
))
12682 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12683 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12685 if (sym
->attr
.external
)
12686 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12687 "at %L", &sym
->declared_at
);
12689 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12690 "at %L", &sym
->declared_at
);
12695 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
12698 /* Symbols that are module procedures with results (functions) have
12699 the types and array specification copied for type checking in
12700 procedures that call them, as well as for saving to a module
12701 file. These symbols can't stand the scrutiny that their results
12703 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12705 /* Make sure that the intrinsic is consistent with its internal
12706 representation. This needs to be done before assigning a default
12707 type to avoid spurious warnings. */
12708 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12709 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
12712 /* Resolve associate names. */
12714 resolve_assoc_var (sym
, true);
12716 /* Assign default type to symbols that need one and don't have one. */
12717 if (sym
->ts
.type
== BT_UNKNOWN
)
12719 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12721 gfc_set_default_type (sym
, 1, NULL
);
12724 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12725 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12726 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12727 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12729 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12731 /* The specific case of an external procedure should emit an error
12732 in the case that there is no implicit type. */
12734 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12737 /* Result may be in another namespace. */
12738 resolve_symbol (sym
->result
);
12740 if (!sym
->result
->attr
.proc_pointer
)
12742 sym
->ts
= sym
->result
->ts
;
12743 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12744 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12745 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12746 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12747 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12752 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12754 bool saved_specification_expr
= specification_expr
;
12755 specification_expr
= true;
12756 gfc_resolve_array_spec (sym
->result
->as
, false);
12757 specification_expr
= saved_specification_expr
;
12760 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12762 as
= CLASS_DATA (sym
)->as
;
12763 class_attr
= CLASS_DATA (sym
)->attr
;
12764 class_attr
.pointer
= class_attr
.class_pointer
;
12768 class_attr
= sym
->attr
;
12773 if (sym
->attr
.contiguous
12774 && (!class_attr
.dimension
12775 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12776 && !class_attr
.pointer
)))
12778 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12779 "array pointer or an assumed-shape or assumed-rank array",
12780 sym
->name
, &sym
->declared_at
);
12784 /* Assumed size arrays and assumed shape arrays must be dummy
12785 arguments. Array-spec's of implied-shape should have been resolved to
12786 AS_EXPLICIT already. */
12790 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12791 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12792 || as
->type
== AS_ASSUMED_SHAPE
)
12793 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
12795 if (as
->type
== AS_ASSUMED_SIZE
)
12796 gfc_error ("Assumed size array at %L must be a dummy argument",
12797 &sym
->declared_at
);
12799 gfc_error ("Assumed shape array at %L must be a dummy argument",
12800 &sym
->declared_at
);
12803 /* TS 29113, C535a. */
12804 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
12805 && !sym
->attr
.select_type_temporary
)
12807 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12808 &sym
->declared_at
);
12811 if (as
->type
== AS_ASSUMED_RANK
12812 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12814 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12815 "CODIMENSION attribute", &sym
->declared_at
);
12820 /* Make sure symbols with known intent or optional are really dummy
12821 variable. Because of ENTRY statement, this has to be deferred
12822 until resolution time. */
12824 if (!sym
->attr
.dummy
12825 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12827 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12831 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12833 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12834 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12838 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12840 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12841 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12843 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12844 "attribute must have constant length",
12845 sym
->name
, &sym
->declared_at
);
12849 if (sym
->ts
.is_c_interop
12850 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12852 gfc_error ("C interoperable character dummy variable '%s' at %L "
12853 "with VALUE attribute must have length one",
12854 sym
->name
, &sym
->declared_at
);
12859 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12860 && sym
->ts
.u
.derived
->attr
.generic
)
12862 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12863 if (!sym
->ts
.u
.derived
)
12865 gfc_error ("The derived type '%s' at %L is of type '%s', "
12866 "which has not been defined", sym
->name
,
12867 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12868 sym
->ts
.type
= BT_UNKNOWN
;
12873 /* Use the same constraints as TYPE(*), except for the type check
12874 and that only scalars and assumed-size arrays are permitted. */
12875 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
12877 if (!sym
->attr
.dummy
)
12879 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12880 "a dummy argument", sym
->name
, &sym
->declared_at
);
12884 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
12885 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
12886 && sym
->ts
.type
!= BT_COMPLEX
)
12888 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12889 "of type TYPE(*) or of an numeric intrinsic type",
12890 sym
->name
, &sym
->declared_at
);
12894 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12895 || sym
->attr
.pointer
|| sym
->attr
.value
)
12897 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12898 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
12899 "attribute", sym
->name
, &sym
->declared_at
);
12903 if (sym
->attr
.intent
== INTENT_OUT
)
12905 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12906 "have the INTENT(OUT) attribute",
12907 sym
->name
, &sym
->declared_at
);
12910 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
12912 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
12913 "either be a scalar or an assumed-size array",
12914 sym
->name
, &sym
->declared_at
);
12918 /* Set the type to TYPE(*) and add a dimension(*) to ensure
12919 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
12921 sym
->ts
.type
= BT_ASSUMED
;
12922 sym
->as
= gfc_get_array_spec ();
12923 sym
->as
->type
= AS_ASSUMED_SIZE
;
12925 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
12927 else if (sym
->ts
.type
== BT_ASSUMED
)
12929 /* TS 29113, C407a. */
12930 if (!sym
->attr
.dummy
)
12932 gfc_error ("Assumed type of variable %s at %L is only permitted "
12933 "for dummy variables", sym
->name
, &sym
->declared_at
);
12936 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12937 || sym
->attr
.pointer
|| sym
->attr
.value
)
12939 gfc_error ("Assumed-type variable %s at %L may not have the "
12940 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12941 sym
->name
, &sym
->declared_at
);
12944 if (sym
->attr
.intent
== INTENT_OUT
)
12946 gfc_error ("Assumed-type variable %s at %L may not have the "
12947 "INTENT(OUT) attribute",
12948 sym
->name
, &sym
->declared_at
);
12951 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12953 gfc_error ("Assumed-type variable %s at %L shall not be an "
12954 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12959 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12960 do this for something that was implicitly typed because that is handled
12961 in gfc_set_default_type. Handle dummy arguments and procedure
12962 definitions separately. Also, anything that is use associated is not
12963 handled here but instead is handled in the module it is declared in.
12964 Finally, derived type definitions are allowed to be BIND(C) since that
12965 only implies that they're interoperable, and they are checked fully for
12966 interoperability when a variable is declared of that type. */
12967 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12968 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12969 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12973 /* First, make sure the variable is declared at the
12974 module-level scope (J3/04-007, Section 15.3). */
12975 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12976 sym
->attr
.in_common
== 0)
12978 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12979 "is neither a COMMON block nor declared at the "
12980 "module level scope", sym
->name
, &(sym
->declared_at
));
12983 else if (sym
->common_head
!= NULL
)
12985 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12989 /* If type() declaration, we need to verify that the components
12990 of the given type are all C interoperable, etc. */
12991 if (sym
->ts
.type
== BT_DERIVED
&&
12992 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12994 /* Make sure the user marked the derived type as BIND(C). If
12995 not, call the verify routine. This could print an error
12996 for the derived type more than once if multiple variables
12997 of that type are declared. */
12998 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12999 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13003 /* Verify the variable itself as C interoperable if it
13004 is BIND(C). It is not possible for this to succeed if
13005 the verify_bind_c_derived_type failed, so don't have to handle
13006 any error returned by verify_bind_c_derived_type. */
13007 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13008 sym
->common_block
);
13013 /* clear the is_bind_c flag to prevent reporting errors more than
13014 once if something failed. */
13015 sym
->attr
.is_bind_c
= 0;
13020 /* If a derived type symbol has reached this point, without its
13021 type being declared, we have an error. Notice that most
13022 conditions that produce undefined derived types have already
13023 been dealt with. However, the likes of:
13024 implicit type(t) (t) ..... call foo (t) will get us here if
13025 the type is not declared in the scope of the implicit
13026 statement. Change the type to BT_UNKNOWN, both because it is so
13027 and to prevent an ICE. */
13028 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13029 && sym
->ts
.u
.derived
->components
== NULL
13030 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13032 gfc_error ("The derived type '%s' at %L is of type '%s', "
13033 "which has not been defined", sym
->name
,
13034 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13035 sym
->ts
.type
= BT_UNKNOWN
;
13039 /* Make sure that the derived type has been resolved and that the
13040 derived type is visible in the symbol's namespace, if it is a
13041 module function and is not PRIVATE. */
13042 if (sym
->ts
.type
== BT_DERIVED
13043 && sym
->ts
.u
.derived
->attr
.use_assoc
13044 && sym
->ns
->proc_name
13045 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13046 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13049 /* Unless the derived-type declaration is use associated, Fortran 95
13050 does not allow public entries of private derived types.
13051 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13052 161 in 95-006r3. */
13053 if (sym
->ts
.type
== BT_DERIVED
13054 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13055 && !sym
->ts
.u
.derived
->attr
.use_assoc
13056 && gfc_check_symbol_access (sym
)
13057 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13058 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13059 "derived type '%s'",
13060 (sym
->attr
.flavor
== FL_PARAMETER
)
13061 ? "parameter" : "variable",
13062 sym
->name
, &sym
->declared_at
,
13063 sym
->ts
.u
.derived
->name
))
13066 /* F2008, C1302. */
13067 if (sym
->ts
.type
== BT_DERIVED
13068 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13069 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13070 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13071 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13073 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13074 "type LOCK_TYPE must be a coarray", sym
->name
,
13075 &sym
->declared_at
);
13079 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13080 default initialization is defined (5.1.2.4.4). */
13081 if (sym
->ts
.type
== BT_DERIVED
13083 && sym
->attr
.intent
== INTENT_OUT
13085 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13087 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13089 if (c
->initializer
)
13091 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13092 "ASSUMED SIZE and so cannot have a default initializer",
13093 sym
->name
, &sym
->declared_at
);
13100 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13101 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13103 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13104 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13109 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13110 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13111 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13112 || class_attr
.codimension
)
13113 && (sym
->attr
.result
|| sym
->result
== sym
))
13115 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13116 "a coarray component", sym
->name
, &sym
->declared_at
);
13121 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13122 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13124 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13125 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13130 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13131 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13132 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13133 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13134 || class_attr
.allocatable
))
13136 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13137 "nonpointer, nonallocatable scalar, which is not a coarray",
13138 sym
->name
, &sym
->declared_at
);
13142 /* F2008, C526. The function-result case was handled above. */
13143 if (class_attr
.codimension
13144 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13145 || sym
->attr
.select_type_temporary
13146 || sym
->ns
->save_all
13147 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13148 || sym
->ns
->proc_name
->attr
.is_main_program
13149 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13151 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13152 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13156 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13157 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13159 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13160 "deferred shape", sym
->name
, &sym
->declared_at
);
13163 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13164 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13166 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13167 "deferred shape", sym
->name
, &sym
->declared_at
);
13172 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13173 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13174 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13175 || (class_attr
.codimension
&& class_attr
.allocatable
))
13176 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13178 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13179 "allocatable coarray or have coarray components",
13180 sym
->name
, &sym
->declared_at
);
13184 if (class_attr
.codimension
&& sym
->attr
.dummy
13185 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13187 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13188 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13189 sym
->ns
->proc_name
->name
);
13193 if (sym
->ts
.type
== BT_LOGICAL
13194 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13195 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13196 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13199 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13200 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13202 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13203 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13204 "%L with non-C_Bool kind in BIND(C) procedure "
13205 "'%s'", sym
->name
, &sym
->declared_at
,
13206 sym
->ns
->proc_name
->name
))
13208 else if (!gfc_logical_kinds
[i
].c_bool
13209 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13210 "'%s' at %L with non-C_Bool kind in "
13211 "BIND(C) procedure '%s'", sym
->name
,
13213 sym
->attr
.function
? sym
->name
13214 : sym
->ns
->proc_name
->name
))
13218 switch (sym
->attr
.flavor
)
13221 if (!resolve_fl_variable (sym
, mp_flag
))
13226 if (!resolve_fl_procedure (sym
, mp_flag
))
13231 if (!resolve_fl_namelist (sym
))
13236 if (!resolve_fl_parameter (sym
))
13244 /* Resolve array specifier. Check as well some constraints
13245 on COMMON blocks. */
13247 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13249 /* Set the formal_arg_flag so that check_conflict will not throw
13250 an error for host associated variables in the specification
13251 expression for an array_valued function. */
13252 if (sym
->attr
.function
&& sym
->as
)
13253 formal_arg_flag
= 1;
13255 saved_specification_expr
= specification_expr
;
13256 specification_expr
= true;
13257 gfc_resolve_array_spec (sym
->as
, check_constant
);
13258 specification_expr
= saved_specification_expr
;
13260 formal_arg_flag
= 0;
13262 /* Resolve formal namespaces. */
13263 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13264 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13265 gfc_resolve (sym
->formal_ns
);
13267 /* Make sure the formal namespace is present. */
13268 if (sym
->formal
&& !sym
->formal_ns
)
13270 gfc_formal_arglist
*formal
= sym
->formal
;
13271 while (formal
&& !formal
->sym
)
13272 formal
= formal
->next
;
13276 sym
->formal_ns
= formal
->sym
->ns
;
13277 if (sym
->ns
!= formal
->sym
->ns
)
13278 sym
->formal_ns
->refs
++;
13282 /* Check threadprivate restrictions. */
13283 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13284 && (!sym
->attr
.in_common
13285 && sym
->module
== NULL
13286 && (sym
->ns
->proc_name
== NULL
13287 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13288 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13290 /* If we have come this far we can apply default-initializers, as
13291 described in 14.7.5, to those variables that have not already
13292 been assigned one. */
13293 if (sym
->ts
.type
== BT_DERIVED
13295 && !sym
->attr
.allocatable
13296 && !sym
->attr
.alloc_comp
)
13298 symbol_attribute
*a
= &sym
->attr
;
13300 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13301 && !a
->in_common
&& !a
->use_assoc
13302 && (a
->referenced
|| a
->result
)
13303 && !(a
->function
&& sym
!= sym
->result
))
13304 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13305 apply_default_init (sym
);
13308 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13309 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13310 && !CLASS_DATA (sym
)->attr
.class_pointer
13311 && !CLASS_DATA (sym
)->attr
.allocatable
)
13312 apply_default_init (sym
);
13314 /* If this symbol has a type-spec, check it. */
13315 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13316 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13317 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13322 /************* Resolve DATA statements *************/
13326 gfc_data_value
*vnode
;
13332 /* Advance the values structure to point to the next value in the data list. */
13335 next_data_value (void)
13337 while (mpz_cmp_ui (values
.left
, 0) == 0)
13340 if (values
.vnode
->next
== NULL
)
13343 values
.vnode
= values
.vnode
->next
;
13344 mpz_set (values
.left
, values
.vnode
->repeat
);
13352 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13358 ar_type mark
= AR_UNKNOWN
;
13360 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13366 if (!gfc_resolve_expr (var
->expr
))
13370 mpz_init_set_si (offset
, 0);
13373 if (e
->expr_type
!= EXPR_VARIABLE
)
13374 gfc_internal_error ("check_data_variable(): Bad expression");
13376 sym
= e
->symtree
->n
.sym
;
13378 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13380 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13381 sym
->name
, &sym
->declared_at
);
13384 if (e
->ref
== NULL
&& sym
->as
)
13386 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13387 " declaration", sym
->name
, where
);
13391 has_pointer
= sym
->attr
.pointer
;
13393 if (gfc_is_coindexed (e
))
13395 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13400 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13402 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13406 && ref
->type
== REF_ARRAY
13407 && ref
->u
.ar
.type
!= AR_FULL
)
13409 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13410 "be a full array", sym
->name
, where
);
13415 if (e
->rank
== 0 || has_pointer
)
13417 mpz_init_set_ui (size
, 1);
13424 /* Find the array section reference. */
13425 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13427 if (ref
->type
!= REF_ARRAY
)
13429 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13435 /* Set marks according to the reference pattern. */
13436 switch (ref
->u
.ar
.type
)
13444 /* Get the start position of array section. */
13445 gfc_get_section_index (ar
, section_index
, &offset
);
13450 gcc_unreachable ();
13453 if (!gfc_array_size (e
, &size
))
13455 gfc_error ("Nonconstant array section at %L in DATA statement",
13457 mpz_clear (offset
);
13464 while (mpz_cmp_ui (size
, 0) > 0)
13466 if (!next_data_value ())
13468 gfc_error ("DATA statement at %L has more variables than values",
13474 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13478 /* If we have more than one element left in the repeat count,
13479 and we have more than one element left in the target variable,
13480 then create a range assignment. */
13481 /* FIXME: Only done for full arrays for now, since array sections
13483 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13484 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13488 if (mpz_cmp (size
, values
.left
) >= 0)
13490 mpz_init_set (range
, values
.left
);
13491 mpz_sub (size
, size
, values
.left
);
13492 mpz_set_ui (values
.left
, 0);
13496 mpz_init_set (range
, size
);
13497 mpz_sub (values
.left
, values
.left
, size
);
13498 mpz_set_ui (size
, 0);
13501 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13504 mpz_add (offset
, offset
, range
);
13511 /* Assign initial value to symbol. */
13514 mpz_sub_ui (values
.left
, values
.left
, 1);
13515 mpz_sub_ui (size
, size
, 1);
13517 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13522 if (mark
== AR_FULL
)
13523 mpz_add_ui (offset
, offset
, 1);
13525 /* Modify the array section indexes and recalculate the offset
13526 for next element. */
13527 else if (mark
== AR_SECTION
)
13528 gfc_advance_section (section_index
, ar
, &offset
);
13532 if (mark
== AR_SECTION
)
13534 for (i
= 0; i
< ar
->dimen
; i
++)
13535 mpz_clear (section_index
[i
]);
13539 mpz_clear (offset
);
13545 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13547 /* Iterate over a list of elements in a DATA statement. */
13550 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13553 iterator_stack frame
;
13554 gfc_expr
*e
, *start
, *end
, *step
;
13555 bool retval
= true;
13557 mpz_init (frame
.value
);
13560 start
= gfc_copy_expr (var
->iter
.start
);
13561 end
= gfc_copy_expr (var
->iter
.end
);
13562 step
= gfc_copy_expr (var
->iter
.step
);
13564 if (!gfc_simplify_expr (start
, 1)
13565 || start
->expr_type
!= EXPR_CONSTANT
)
13567 gfc_error ("start of implied-do loop at %L could not be "
13568 "simplified to a constant value", &start
->where
);
13572 if (!gfc_simplify_expr (end
, 1)
13573 || end
->expr_type
!= EXPR_CONSTANT
)
13575 gfc_error ("end of implied-do loop at %L could not be "
13576 "simplified to a constant value", &start
->where
);
13580 if (!gfc_simplify_expr (step
, 1)
13581 || step
->expr_type
!= EXPR_CONSTANT
)
13583 gfc_error ("step of implied-do loop at %L could not be "
13584 "simplified to a constant value", &start
->where
);
13589 mpz_set (trip
, end
->value
.integer
);
13590 mpz_sub (trip
, trip
, start
->value
.integer
);
13591 mpz_add (trip
, trip
, step
->value
.integer
);
13593 mpz_div (trip
, trip
, step
->value
.integer
);
13595 mpz_set (frame
.value
, start
->value
.integer
);
13597 frame
.prev
= iter_stack
;
13598 frame
.variable
= var
->iter
.var
->symtree
;
13599 iter_stack
= &frame
;
13601 while (mpz_cmp_ui (trip
, 0) > 0)
13603 if (!traverse_data_var (var
->list
, where
))
13609 e
= gfc_copy_expr (var
->expr
);
13610 if (!gfc_simplify_expr (e
, 1))
13617 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13619 mpz_sub_ui (trip
, trip
, 1);
13623 mpz_clear (frame
.value
);
13626 gfc_free_expr (start
);
13627 gfc_free_expr (end
);
13628 gfc_free_expr (step
);
13630 iter_stack
= frame
.prev
;
13635 /* Type resolve variables in the variable list of a DATA statement. */
13638 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13642 for (; var
; var
= var
->next
)
13644 if (var
->expr
== NULL
)
13645 t
= traverse_data_list (var
, where
);
13647 t
= check_data_variable (var
, where
);
13657 /* Resolve the expressions and iterators associated with a data statement.
13658 This is separate from the assignment checking because data lists should
13659 only be resolved once. */
13662 resolve_data_variables (gfc_data_variable
*d
)
13664 for (; d
; d
= d
->next
)
13666 if (d
->list
== NULL
)
13668 if (!gfc_resolve_expr (d
->expr
))
13673 if (!gfc_resolve_iterator (&d
->iter
, false, true))
13676 if (!resolve_data_variables (d
->list
))
13685 /* Resolve a single DATA statement. We implement this by storing a pointer to
13686 the value list into static variables, and then recursively traversing the
13687 variables list, expanding iterators and such. */
13690 resolve_data (gfc_data
*d
)
13693 if (!resolve_data_variables (d
->var
))
13696 values
.vnode
= d
->value
;
13697 if (d
->value
== NULL
)
13698 mpz_set_ui (values
.left
, 0);
13700 mpz_set (values
.left
, d
->value
->repeat
);
13702 if (!traverse_data_var (d
->var
, &d
->where
))
13705 /* At this point, we better not have any values left. */
13707 if (next_data_value ())
13708 gfc_error ("DATA statement at %L has more values than variables",
13713 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13714 accessed by host or use association, is a dummy argument to a pure function,
13715 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13716 is storage associated with any such variable, shall not be used in the
13717 following contexts: (clients of this function). */
13719 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13720 procedure. Returns zero if assignment is OK, nonzero if there is a
13723 gfc_impure_variable (gfc_symbol
*sym
)
13728 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13731 /* Check if the symbol's ns is inside the pure procedure. */
13732 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13736 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13740 proc
= sym
->ns
->proc_name
;
13741 if (sym
->attr
.dummy
13742 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13743 || proc
->attr
.function
))
13746 /* TODO: Sort out what can be storage associated, if anything, and include
13747 it here. In principle equivalences should be scanned but it does not
13748 seem to be possible to storage associate an impure variable this way. */
13753 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13754 current namespace is inside a pure procedure. */
13757 gfc_pure (gfc_symbol
*sym
)
13759 symbol_attribute attr
;
13764 /* Check if the current namespace or one of its parents
13765 belongs to a pure procedure. */
13766 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13768 sym
= ns
->proc_name
;
13772 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13780 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13784 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13785 checks if the current namespace is implicitly pure. Note that this
13786 function returns false for a PURE procedure. */
13789 gfc_implicit_pure (gfc_symbol
*sym
)
13795 /* Check if the current procedure is implicit_pure. Walk up
13796 the procedure list until we find a procedure. */
13797 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13799 sym
= ns
->proc_name
;
13803 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13808 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13809 && !sym
->attr
.pure
;
13813 /* Test whether the current procedure is elemental or not. */
13816 gfc_elemental (gfc_symbol
*sym
)
13818 symbol_attribute attr
;
13821 sym
= gfc_current_ns
->proc_name
;
13826 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13830 /* Warn about unused labels. */
13833 warn_unused_fortran_label (gfc_st_label
*label
)
13838 warn_unused_fortran_label (label
->left
);
13840 if (label
->defined
== ST_LABEL_UNKNOWN
)
13843 switch (label
->referenced
)
13845 case ST_LABEL_UNKNOWN
:
13846 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13850 case ST_LABEL_BAD_TARGET
:
13851 gfc_warning ("Label %d at %L defined but cannot be used",
13852 label
->value
, &label
->where
);
13859 warn_unused_fortran_label (label
->right
);
13863 /* Returns the sequence type of a symbol or sequence. */
13866 sequence_type (gfc_typespec ts
)
13875 if (ts
.u
.derived
->components
== NULL
)
13876 return SEQ_NONDEFAULT
;
13878 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13879 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13880 if (sequence_type (c
->ts
) != result
)
13886 if (ts
.kind
!= gfc_default_character_kind
)
13887 return SEQ_NONDEFAULT
;
13889 return SEQ_CHARACTER
;
13892 if (ts
.kind
!= gfc_default_integer_kind
)
13893 return SEQ_NONDEFAULT
;
13895 return SEQ_NUMERIC
;
13898 if (!(ts
.kind
== gfc_default_real_kind
13899 || ts
.kind
== gfc_default_double_kind
))
13900 return SEQ_NONDEFAULT
;
13902 return SEQ_NUMERIC
;
13905 if (ts
.kind
!= gfc_default_complex_kind
)
13906 return SEQ_NONDEFAULT
;
13908 return SEQ_NUMERIC
;
13911 if (ts
.kind
!= gfc_default_logical_kind
)
13912 return SEQ_NONDEFAULT
;
13914 return SEQ_NUMERIC
;
13917 return SEQ_NONDEFAULT
;
13922 /* Resolve derived type EQUIVALENCE object. */
13925 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13927 gfc_component
*c
= derived
->components
;
13932 /* Shall not be an object of nonsequence derived type. */
13933 if (!derived
->attr
.sequence
)
13935 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13936 "attribute to be an EQUIVALENCE object", sym
->name
,
13941 /* Shall not have allocatable components. */
13942 if (derived
->attr
.alloc_comp
)
13944 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13945 "components to be an EQUIVALENCE object",sym
->name
,
13950 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13952 gfc_error ("Derived type variable '%s' at %L with default "
13953 "initialization cannot be in EQUIVALENCE with a variable "
13954 "in COMMON", sym
->name
, &e
->where
);
13958 for (; c
; c
= c
->next
)
13960 if (c
->ts
.type
== BT_DERIVED
13961 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
13964 /* Shall not be an object of sequence derived type containing a pointer
13965 in the structure. */
13966 if (c
->attr
.pointer
)
13968 gfc_error ("Derived type variable '%s' at %L with pointer "
13969 "component(s) cannot be an EQUIVALENCE object",
13970 sym
->name
, &e
->where
);
13978 /* Resolve equivalence object.
13979 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13980 an allocatable array, an object of nonsequence derived type, an object of
13981 sequence derived type containing a pointer at any level of component
13982 selection, an automatic object, a function name, an entry name, a result
13983 name, a named constant, a structure component, or a subobject of any of
13984 the preceding objects. A substring shall not have length zero. A
13985 derived type shall not have components with default initialization nor
13986 shall two objects of an equivalence group be initialized.
13987 Either all or none of the objects shall have an protected attribute.
13988 The simple constraints are done in symbol.c(check_conflict) and the rest
13989 are implemented here. */
13992 resolve_equivalence (gfc_equiv
*eq
)
13995 gfc_symbol
*first_sym
;
13998 locus
*last_where
= NULL
;
13999 seq_type eq_type
, last_eq_type
;
14000 gfc_typespec
*last_ts
;
14001 int object
, cnt_protected
;
14004 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14006 first_sym
= eq
->expr
->symtree
->n
.sym
;
14010 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14014 e
->ts
= e
->symtree
->n
.sym
->ts
;
14015 /* match_varspec might not know yet if it is seeing
14016 array reference or substring reference, as it doesn't
14018 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14020 gfc_ref
*ref
= e
->ref
;
14021 sym
= e
->symtree
->n
.sym
;
14023 if (sym
->attr
.dimension
)
14025 ref
->u
.ar
.as
= sym
->as
;
14029 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14030 if (e
->ts
.type
== BT_CHARACTER
14032 && ref
->type
== REF_ARRAY
14033 && ref
->u
.ar
.dimen
== 1
14034 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14035 && ref
->u
.ar
.stride
[0] == NULL
)
14037 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14038 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14041 /* Optimize away the (:) reference. */
14042 if (start
== NULL
&& end
== NULL
)
14045 e
->ref
= ref
->next
;
14047 e
->ref
->next
= ref
->next
;
14052 ref
->type
= REF_SUBSTRING
;
14054 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14056 ref
->u
.ss
.start
= start
;
14057 if (end
== NULL
&& e
->ts
.u
.cl
)
14058 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14059 ref
->u
.ss
.end
= end
;
14060 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14067 /* Any further ref is an error. */
14070 gcc_assert (ref
->type
== REF_ARRAY
);
14071 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14077 if (!gfc_resolve_expr (e
))
14080 sym
= e
->symtree
->n
.sym
;
14082 if (sym
->attr
.is_protected
)
14084 if (cnt_protected
> 0 && cnt_protected
!= object
)
14086 gfc_error ("Either all or none of the objects in the "
14087 "EQUIVALENCE set at %L shall have the "
14088 "PROTECTED attribute",
14093 /* Shall not equivalence common block variables in a PURE procedure. */
14094 if (sym
->ns
->proc_name
14095 && sym
->ns
->proc_name
->attr
.pure
14096 && sym
->attr
.in_common
)
14098 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14099 "object in the pure procedure '%s'",
14100 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14104 /* Shall not be a named constant. */
14105 if (e
->expr_type
== EXPR_CONSTANT
)
14107 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14108 "object", sym
->name
, &e
->where
);
14112 if (e
->ts
.type
== BT_DERIVED
14113 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14116 /* Check that the types correspond correctly:
14118 A numeric sequence structure may be equivalenced to another sequence
14119 structure, an object of default integer type, default real type, double
14120 precision real type, default logical type such that components of the
14121 structure ultimately only become associated to objects of the same
14122 kind. A character sequence structure may be equivalenced to an object
14123 of default character kind or another character sequence structure.
14124 Other objects may be equivalenced only to objects of the same type and
14125 kind parameters. */
14127 /* Identical types are unconditionally OK. */
14128 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14129 goto identical_types
;
14131 last_eq_type
= sequence_type (*last_ts
);
14132 eq_type
= sequence_type (sym
->ts
);
14134 /* Since the pair of objects is not of the same type, mixed or
14135 non-default sequences can be rejected. */
14137 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14138 "statement at %L with different type objects";
14140 && last_eq_type
== SEQ_MIXED
14141 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14142 || (eq_type
== SEQ_MIXED
14143 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14146 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14147 "statement at %L with objects of different type";
14149 && last_eq_type
== SEQ_NONDEFAULT
14150 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14151 || (eq_type
== SEQ_NONDEFAULT
14152 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14155 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14156 "EQUIVALENCE statement at %L";
14157 if (last_eq_type
== SEQ_CHARACTER
14158 && eq_type
!= SEQ_CHARACTER
14159 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14162 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14163 "EQUIVALENCE statement at %L";
14164 if (last_eq_type
== SEQ_NUMERIC
14165 && eq_type
!= SEQ_NUMERIC
14166 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14171 last_where
= &e
->where
;
14176 /* Shall not be an automatic array. */
14177 if (e
->ref
->type
== REF_ARRAY
14178 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14180 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14181 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14188 /* Shall not be a structure component. */
14189 if (r
->type
== REF_COMPONENT
)
14191 gfc_error ("Structure component '%s' at %L cannot be an "
14192 "EQUIVALENCE object",
14193 r
->u
.c
.component
->name
, &e
->where
);
14197 /* A substring shall not have length zero. */
14198 if (r
->type
== REF_SUBSTRING
)
14200 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14202 gfc_error ("Substring at %L has length zero",
14203 &r
->u
.ss
.start
->where
);
14213 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14216 resolve_fntype (gfc_namespace
*ns
)
14218 gfc_entry_list
*el
;
14221 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14224 /* If there are any entries, ns->proc_name is the entry master
14225 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14227 sym
= ns
->entries
->sym
;
14229 sym
= ns
->proc_name
;
14230 if (sym
->result
== sym
14231 && sym
->ts
.type
== BT_UNKNOWN
14232 && !gfc_set_default_type (sym
, 0, NULL
)
14233 && !sym
->attr
.untyped
)
14235 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14236 sym
->name
, &sym
->declared_at
);
14237 sym
->attr
.untyped
= 1;
14240 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14241 && !sym
->attr
.contained
14242 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14243 && gfc_check_symbol_access (sym
))
14245 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14246 "%L of PRIVATE type '%s'", sym
->name
,
14247 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14251 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14253 if (el
->sym
->result
== el
->sym
14254 && el
->sym
->ts
.type
== BT_UNKNOWN
14255 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14256 && !el
->sym
->attr
.untyped
)
14258 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14259 el
->sym
->name
, &el
->sym
->declared_at
);
14260 el
->sym
->attr
.untyped
= 1;
14266 /* 12.3.2.1.1 Defined operators. */
14269 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14271 gfc_formal_arglist
*formal
;
14273 if (!sym
->attr
.function
)
14275 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14276 sym
->name
, &where
);
14280 if (sym
->ts
.type
== BT_CHARACTER
14281 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14282 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14283 && sym
->result
->ts
.u
.cl
->length
))
14285 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14286 "character length", sym
->name
, &where
);
14290 formal
= gfc_sym_get_dummy_args (sym
);
14291 if (!formal
|| !formal
->sym
)
14293 gfc_error ("User operator procedure '%s' at %L must have at least "
14294 "one argument", sym
->name
, &where
);
14298 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14300 gfc_error ("First argument of operator interface at %L must be "
14301 "INTENT(IN)", &where
);
14305 if (formal
->sym
->attr
.optional
)
14307 gfc_error ("First argument of operator interface at %L cannot be "
14308 "optional", &where
);
14312 formal
= formal
->next
;
14313 if (!formal
|| !formal
->sym
)
14316 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14318 gfc_error ("Second argument of operator interface at %L must be "
14319 "INTENT(IN)", &where
);
14323 if (formal
->sym
->attr
.optional
)
14325 gfc_error ("Second argument of operator interface at %L cannot be "
14326 "optional", &where
);
14332 gfc_error ("Operator interface at %L must have, at most, two "
14333 "arguments", &where
);
14341 gfc_resolve_uops (gfc_symtree
*symtree
)
14343 gfc_interface
*itr
;
14345 if (symtree
== NULL
)
14348 gfc_resolve_uops (symtree
->left
);
14349 gfc_resolve_uops (symtree
->right
);
14351 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14352 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14356 /* Examine all of the expressions associated with a program unit,
14357 assign types to all intermediate expressions, make sure that all
14358 assignments are to compatible types and figure out which names
14359 refer to which functions or subroutines. It doesn't check code
14360 block, which is handled by resolve_code. */
14363 resolve_types (gfc_namespace
*ns
)
14369 gfc_namespace
* old_ns
= gfc_current_ns
;
14371 /* Check that all IMPLICIT types are ok. */
14372 if (!ns
->seen_implicit_none
)
14375 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14376 if (ns
->set_flag
[letter
]
14377 && !resolve_typespec_used (&ns
->default_type
[letter
],
14378 &ns
->implicit_loc
[letter
], NULL
))
14382 gfc_current_ns
= ns
;
14384 resolve_entries (ns
);
14386 resolve_common_vars (ns
->blank_common
.head
, false);
14387 resolve_common_blocks (ns
->common_root
);
14389 resolve_contained_functions (ns
);
14391 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14392 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14393 resolve_formal_arglist (ns
->proc_name
);
14395 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14397 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14398 resolve_charlen (cl
);
14400 gfc_traverse_ns (ns
, resolve_symbol
);
14402 resolve_fntype (ns
);
14404 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14406 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14407 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14408 "also be PURE", n
->proc_name
->name
,
14409 &n
->proc_name
->declared_at
);
14415 do_concurrent_flag
= 0;
14416 gfc_check_interfaces (ns
);
14418 gfc_traverse_ns (ns
, resolve_values
);
14424 for (d
= ns
->data
; d
; d
= d
->next
)
14428 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14430 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14432 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14433 resolve_equivalence (eq
);
14435 /* Warn about unused labels. */
14436 if (warn_unused_label
)
14437 warn_unused_fortran_label (ns
->st_labels
);
14439 gfc_resolve_uops (ns
->uop_root
);
14441 gfc_current_ns
= old_ns
;
14445 /* Call resolve_code recursively. */
14448 resolve_codes (gfc_namespace
*ns
)
14451 bitmap_obstack old_obstack
;
14453 if (ns
->resolved
== 1)
14456 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14459 gfc_current_ns
= ns
;
14461 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14462 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14465 /* Set to an out of range value. */
14466 current_entry_id
= -1;
14468 old_obstack
= labels_obstack
;
14469 bitmap_obstack_initialize (&labels_obstack
);
14471 resolve_code (ns
->code
, ns
);
14473 bitmap_obstack_release (&labels_obstack
);
14474 labels_obstack
= old_obstack
;
14478 /* This function is called after a complete program unit has been compiled.
14479 Its purpose is to examine all of the expressions associated with a program
14480 unit, assign types to all intermediate expressions, make sure that all
14481 assignments are to compatible types and figure out which names refer to
14482 which functions or subroutines. */
14485 gfc_resolve (gfc_namespace
*ns
)
14487 gfc_namespace
*old_ns
;
14488 code_stack
*old_cs_base
;
14494 old_ns
= gfc_current_ns
;
14495 old_cs_base
= cs_base
;
14497 resolve_types (ns
);
14498 component_assignment_level
= 0;
14499 resolve_codes (ns
);
14501 gfc_current_ns
= old_ns
;
14502 cs_base
= old_cs_base
;
14505 gfc_run_passes (ns
);