1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code
*head
, *current
;
48 struct code_stack
*prev
;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels
;
57 static code_stack
*cs_base
= NULL
;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag
;
63 int gfc_do_concurrent_flag
;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg
= false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg
= false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag
;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag
= 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr
= false;
84 /* The id of the last entry seen. */
85 static int current_entry_id
;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack
;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument
= false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag
;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
104 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
120 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
125 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type '%s' used at %L",
129 ts
->u
.derived
->name
, where
);
140 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
142 /* Several checks for F08:C1216. */
143 if (ifc
->attr
.procedure
)
145 gfc_error ("Interface '%s' at %L is declared "
146 "in a later PROCEDURE statement", ifc
->name
, where
);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface
*gen
= ifc
->generic
;
154 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
158 gfc_error ("Interface '%s' at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface '%s' at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
170 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
171 ifc
->attr
.intrinsic
= 1;
172 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
174 gfc_error ("Intrinsic procedure '%s' not allowed in "
175 "PROCEDURE statement at %L", ifc
->name
, where
);
178 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
180 gfc_error ("Interface '%s' at %L must be explicit", ifc
->name
, where
);
187 static void resolve_symbol (gfc_symbol
*sym
);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol
*sym
)
195 gfc_symbol
*ifc
= sym
->ts
.interface
;
202 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
203 sym
->name
, &sym
->declared_at
);
206 if (!check_proc_interface (ifc
, &sym
->declared_at
))
209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc
);
213 if (ifc
->attr
.intrinsic
)
214 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
218 sym
->ts
= ifc
->result
->ts
;
223 sym
->ts
.interface
= ifc
;
224 sym
->attr
.function
= ifc
->attr
.function
;
225 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.pure
= ifc
->attr
.pure
;
230 sym
->attr
.elemental
= ifc
->attr
.elemental
;
231 sym
->attr
.dimension
= ifc
->attr
.dimension
;
232 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
233 sym
->attr
.recursive
= ifc
->attr
.recursive
;
234 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
235 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
236 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
237 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
238 /* Copy array spec. */
239 sym
->as
= gfc_copy_array_spec (ifc
->as
);
240 /* Copy char length. */
241 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
243 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
244 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
245 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol
*proc
)
266 gfc_formal_arglist
*f
;
268 bool saved_specification_expr
;
271 if (proc
->result
!= NULL
)
276 if (gfc_elemental (proc
)
277 || sym
->attr
.pointer
|| sym
->attr
.allocatable
278 || (sym
->as
&& sym
->as
->rank
!= 0))
280 proc
->attr
.always_explicit
= 1;
281 sym
->attr
.always_explicit
= 1;
286 for (f
= proc
->formal
; f
; f
= f
->next
)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc
))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "'%s' at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "'%s' at %L is not allowed", proc
->name
,
305 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
306 && !resolve_procedure_interface (sym
))
309 if (strcmp (proc
->name
, sym
->name
) == 0)
311 gfc_error ("Self-referential argument "
312 "'%s' at %L is not allowed", sym
->name
,
317 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
318 resolve_formal_arglist (sym
);
320 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
322 if (sym
->attr
.flavor
== FL_UNKNOWN
)
323 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
327 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
328 && (!sym
->attr
.function
|| sym
->result
== sym
))
329 gfc_set_default_type (sym
, 1, sym
->ns
);
332 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
333 ? CLASS_DATA (sym
)->as
: sym
->as
;
335 saved_specification_expr
= specification_expr
;
336 specification_expr
= true;
337 gfc_resolve_array_spec (as
, 0);
338 specification_expr
= saved_specification_expr
;
340 /* We can't tell if an array with dimension (:) is assumed or deferred
341 shape until we know if it has the pointer or allocatable attributes.
343 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
344 && ((sym
->ts
.type
!= BT_CLASS
345 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
346 || (sym
->ts
.type
== BT_CLASS
347 && !(CLASS_DATA (sym
)->attr
.class_pointer
348 || CLASS_DATA (sym
)->attr
.allocatable
)))
349 && sym
->attr
.flavor
!= FL_PROCEDURE
)
351 as
->type
= AS_ASSUMED_SHAPE
;
352 for (i
= 0; i
< as
->rank
; i
++)
353 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
356 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
357 || (as
&& as
->type
== AS_ASSUMED_RANK
)
358 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
359 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
360 && (CLASS_DATA (sym
)->attr
.class_pointer
361 || CLASS_DATA (sym
)->attr
.allocatable
362 || CLASS_DATA (sym
)->attr
.target
))
363 || sym
->attr
.optional
)
365 proc
->attr
.always_explicit
= 1;
367 proc
->result
->attr
.always_explicit
= 1;
370 /* If the flavor is unknown at this point, it has to be a variable.
371 A procedure specification would have already set the type. */
373 if (sym
->attr
.flavor
== FL_UNKNOWN
)
374 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
383 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
384 "also be PURE", sym
->name
, &sym
->declared_at
);
388 else if (!sym
->attr
.pointer
)
390 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
393 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
394 " of pure function '%s' at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument '%s' of pure function '%s' at %L must "
399 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
403 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
406 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
407 " of pure subroutine '%s' at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
412 "must have its INTENT specified or have the "
413 "VALUE attribute", sym
->name
, proc
->name
,
419 if (proc
->attr
.implicit_pure
)
421 if (sym
->attr
.flavor
== FL_PROCEDURE
)
424 proc
->attr
.implicit_pure
= 0;
426 else if (!sym
->attr
.pointer
)
428 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
430 proc
->attr
.implicit_pure
= 0;
432 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
434 proc
->attr
.implicit_pure
= 0;
438 if (gfc_elemental (proc
))
441 if (sym
->attr
.codimension
442 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
443 && CLASS_DATA (sym
)->attr
.codimension
))
445 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
446 "procedure", sym
->name
, &sym
->declared_at
);
450 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
451 && CLASS_DATA (sym
)->as
))
453 gfc_error ("Argument '%s' of elemental procedure at %L must "
454 "be scalar", sym
->name
, &sym
->declared_at
);
458 if (sym
->attr
.allocatable
459 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->attr
.allocatable
))
462 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
463 "have the ALLOCATABLE attribute", sym
->name
,
468 if (sym
->attr
.pointer
469 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
470 && CLASS_DATA (sym
)->attr
.class_pointer
))
472 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
473 "have the POINTER attribute", sym
->name
,
478 if (sym
->attr
.flavor
== FL_PROCEDURE
)
480 gfc_error ("Dummy procedure '%s' not allowed in elemental "
481 "procedure '%s' at %L", sym
->name
, proc
->name
,
486 /* Fortran 2008 Corrigendum 1, C1290a. */
487 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
489 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
490 "have its INTENT specified or have the VALUE "
491 "attribute", sym
->name
, proc
->name
,
497 /* Each dummy shall be specified to be scalar. */
498 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
502 gfc_error ("Argument '%s' of statement function at %L must "
503 "be scalar", sym
->name
, &sym
->declared_at
);
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
510 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
512 gfc_error ("Character-valued argument '%s' of statement "
513 "function at %L must have constant length",
514 sym
->name
, &sym
->declared_at
);
524 /* Work function called when searching for symbols that have argument lists
525 associated with them. */
528 find_arglists (gfc_symbol
*sym
)
530 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
531 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
534 resolve_formal_arglist (sym
);
538 /* Given a namespace, resolve all formal argument lists within the namespace.
542 resolve_formal_arglists (gfc_namespace
*ns
)
547 gfc_traverse_ns (ns
, find_arglists
);
552 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
556 /* If this namespace is not a function or an entry master function,
558 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
559 || sym
->attr
.entry_master
)
562 /* Try to find out of what the return type is. */
563 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
565 t
= gfc_set_default_type (sym
->result
, 0, ns
);
567 if (!t
&& !sym
->result
->attr
.untyped
)
569 if (sym
->result
== sym
)
570 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
571 sym
->name
, &sym
->declared_at
);
572 else if (!sym
->result
->attr
.proc_pointer
)
573 gfc_error ("Result '%s' of contained function '%s' at %L has "
574 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
575 &sym
->result
->declared_at
);
576 sym
->result
->attr
.untyped
= 1;
580 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
581 type, lists the only ways a character length value of * can be used:
582 dummy arguments of procedures, named constants, and function results
583 in external functions. Internal function results and results of module
584 procedures are not on this list, ergo, not permitted. */
586 if (sym
->result
->ts
.type
== BT_CHARACTER
)
588 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
589 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
591 /* See if this is a module-procedure and adapt error message
594 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
595 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
597 gfc_error ("Character-valued %s '%s' at %L must not be"
599 module_proc
? _("module procedure")
600 : _("internal function"),
601 sym
->name
, &sym
->declared_at
);
607 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
608 introduce duplicates. */
611 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
613 gfc_formal_arglist
*f
, *new_arglist
;
616 for (; new_args
!= NULL
; new_args
= new_args
->next
)
618 new_sym
= new_args
->sym
;
619 /* See if this arg is already in the formal argument list. */
620 for (f
= proc
->formal
; f
; f
= f
->next
)
622 if (new_sym
== f
->sym
)
629 /* Add a new argument. Argument order is not important. */
630 new_arglist
= gfc_get_formal_arglist ();
631 new_arglist
->sym
= new_sym
;
632 new_arglist
->next
= proc
->formal
;
633 proc
->formal
= new_arglist
;
638 /* Flag the arguments that are not present in all entries. */
641 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
643 gfc_formal_arglist
*f
, *head
;
646 for (f
= proc
->formal
; f
; f
= f
->next
)
651 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
653 if (new_args
->sym
== f
->sym
)
660 f
->sym
->attr
.not_always_present
= 1;
665 /* Resolve alternate entry points. If a symbol has multiple entry points we
666 create a new master symbol for the main routine, and turn the existing
667 symbol into an entry point. */
670 resolve_entries (gfc_namespace
*ns
)
672 gfc_namespace
*old_ns
;
676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
677 static int master_count
= 0;
679 if (ns
->proc_name
== NULL
)
682 /* No need to do anything if this procedure doesn't have alternate entry
687 /* We may already have resolved alternate entry points. */
688 if (ns
->proc_name
->attr
.entry_master
)
691 /* If this isn't a procedure something has gone horribly wrong. */
692 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
694 /* Remember the current namespace. */
695 old_ns
= gfc_current_ns
;
699 /* Add the main entry point to the list of entry points. */
700 el
= gfc_get_entry_list ();
701 el
->sym
= ns
->proc_name
;
703 el
->next
= ns
->entries
;
705 ns
->proc_name
->attr
.entry
= 1;
707 /* If it is a module function, it needs to be in the right namespace
708 so that gfc_get_fake_result_decl can gather up the results. The
709 need for this arose in get_proc_name, where these beasts were
710 left in their own namespace, to keep prior references linked to
711 the entry declaration.*/
712 if (ns
->proc_name
->attr
.function
713 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
716 /* Do the same for entries where the master is not a module
717 procedure. These are retained in the module namespace because
718 of the module procedure declaration. */
719 for (el
= el
->next
; el
; el
= el
->next
)
720 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
721 && el
->sym
->attr
.mod_proc
)
725 /* Add an entry statement for it. */
726 c
= gfc_get_code (EXEC_ENTRY
);
731 /* Create a new symbol for the master function. */
732 /* Give the internal function a unique name (within this file).
733 Also include the function name so the user has some hope of figuring
734 out what is going on. */
735 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
736 master_count
++, ns
->proc_name
->name
);
737 gfc_get_ha_symbol (name
, &proc
);
738 gcc_assert (proc
!= NULL
);
740 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
741 if (ns
->proc_name
->attr
.subroutine
)
742 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
746 gfc_typespec
*ts
, *fts
;
747 gfc_array_spec
*as
, *fas
;
748 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
750 fas
= ns
->entries
->sym
->as
;
751 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
752 fts
= &ns
->entries
->sym
->result
->ts
;
753 if (fts
->type
== BT_UNKNOWN
)
754 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
755 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
757 ts
= &el
->sym
->result
->ts
;
759 as
= as
? as
: el
->sym
->result
->as
;
760 if (ts
->type
== BT_UNKNOWN
)
761 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
763 if (! gfc_compare_types (ts
, fts
)
764 || (el
->sym
->result
->attr
.dimension
765 != ns
->entries
->sym
->result
->attr
.dimension
)
766 || (el
->sym
->result
->attr
.pointer
767 != ns
->entries
->sym
->result
->attr
.pointer
))
769 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
770 && gfc_compare_array_spec (as
, fas
) == 0)
771 gfc_error ("Function %s at %L has entries with mismatched "
772 "array specifications", ns
->entries
->sym
->name
,
773 &ns
->entries
->sym
->declared_at
);
774 /* The characteristics need to match and thus both need to have
775 the same string length, i.e. both len=*, or both len=4.
776 Having both len=<variable> is also possible, but difficult to
777 check at compile time. */
778 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
779 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
780 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
782 && ts
->u
.cl
->length
->expr_type
783 != fts
->u
.cl
->length
->expr_type
)
785 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
786 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
787 fts
->u
.cl
->length
->value
.integer
) != 0)))
788 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
789 "entries returning variables of different "
790 "string lengths", ns
->entries
->sym
->name
,
791 &ns
->entries
->sym
->declared_at
);
796 sym
= ns
->entries
->sym
->result
;
797 /* All result types the same. */
799 if (sym
->attr
.dimension
)
800 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
801 if (sym
->attr
.pointer
)
802 gfc_add_pointer (&proc
->attr
, NULL
);
806 /* Otherwise the result will be passed through a union by
808 proc
->attr
.mixed_entry_master
= 1;
809 for (el
= ns
->entries
; el
; el
= el
->next
)
811 sym
= el
->sym
->result
;
812 if (sym
->attr
.dimension
)
814 if (el
== ns
->entries
)
815 gfc_error ("FUNCTION result %s can't be an array in "
816 "FUNCTION %s at %L", sym
->name
,
817 ns
->entries
->sym
->name
, &sym
->declared_at
);
819 gfc_error ("ENTRY result %s can't be an array in "
820 "FUNCTION %s at %L", sym
->name
,
821 ns
->entries
->sym
->name
, &sym
->declared_at
);
823 else if (sym
->attr
.pointer
)
825 if (el
== ns
->entries
)
826 gfc_error ("FUNCTION result %s can't be a POINTER in "
827 "FUNCTION %s at %L", sym
->name
,
828 ns
->entries
->sym
->name
, &sym
->declared_at
);
830 gfc_error ("ENTRY result %s can't be a POINTER in "
831 "FUNCTION %s at %L", sym
->name
,
832 ns
->entries
->sym
->name
, &sym
->declared_at
);
837 if (ts
->type
== BT_UNKNOWN
)
838 ts
= gfc_get_default_type (sym
->name
, NULL
);
842 if (ts
->kind
== gfc_default_integer_kind
)
846 if (ts
->kind
== gfc_default_real_kind
847 || ts
->kind
== gfc_default_double_kind
)
851 if (ts
->kind
== gfc_default_complex_kind
)
855 if (ts
->kind
== gfc_default_logical_kind
)
859 /* We will issue error elsewhere. */
867 if (el
== ns
->entries
)
868 gfc_error ("FUNCTION result %s can't be of type %s "
869 "in FUNCTION %s at %L", sym
->name
,
870 gfc_typename (ts
), ns
->entries
->sym
->name
,
873 gfc_error ("ENTRY result %s can't be of type %s "
874 "in FUNCTION %s at %L", sym
->name
,
875 gfc_typename (ts
), ns
->entries
->sym
->name
,
882 proc
->attr
.access
= ACCESS_PRIVATE
;
883 proc
->attr
.entry_master
= 1;
885 /* Merge all the entry point arguments. */
886 for (el
= ns
->entries
; el
; el
= el
->next
)
887 merge_argument_lists (proc
, el
->sym
->formal
);
889 /* Check the master formal arguments for any that are not
890 present in all entry points. */
891 for (el
= ns
->entries
; el
; el
= el
->next
)
892 check_argument_lists (proc
, el
->sym
->formal
);
894 /* Use the master function for the function body. */
895 ns
->proc_name
= proc
;
897 /* Finalize the new symbols. */
898 gfc_commit_symbols ();
900 /* Restore the original namespace. */
901 gfc_current_ns
= old_ns
;
905 /* Resolve common variables. */
907 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
909 gfc_symbol
*csym
= sym
;
911 for (; csym
; csym
= csym
->common_next
)
913 if (csym
->value
|| csym
->attr
.data
)
915 if (!csym
->ns
->is_block_data
)
916 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
917 "but only in BLOCK DATA initialization is "
918 "allowed", csym
->name
, &csym
->declared_at
);
919 else if (!named_common
)
920 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
921 "in a blank COMMON but initialization is only "
922 "allowed in named common blocks", csym
->name
,
926 if (UNLIMITED_POLY (csym
))
927 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
928 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
930 if (csym
->ts
.type
!= BT_DERIVED
)
933 if (!(csym
->ts
.u
.derived
->attr
.sequence
934 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
935 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
936 "has neither the SEQUENCE nor the BIND(C) "
937 "attribute", csym
->name
, &csym
->declared_at
);
938 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
939 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
940 "has an ultimate component that is "
941 "allocatable", csym
->name
, &csym
->declared_at
);
942 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
943 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
944 "may not have default initializer", csym
->name
,
947 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
948 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
952 /* Resolve common blocks. */
954 resolve_common_blocks (gfc_symtree
*common_root
)
959 if (common_root
== NULL
)
962 if (common_root
->left
)
963 resolve_common_blocks (common_root
->left
);
964 if (common_root
->right
)
965 resolve_common_blocks (common_root
->right
);
967 resolve_common_vars (common_root
->n
.common
->head
, true);
969 /* The common name is a global name - in Fortran 2003 also if it has a
970 C binding name, since Fortran 2008 only the C binding name is a global
972 if (!common_root
->n
.common
->binding_label
973 || gfc_notification_std (GFC_STD_F2008
))
975 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
976 common_root
->n
.common
->name
);
978 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
979 && gsym
->type
== GSYM_COMMON
980 && ((common_root
->n
.common
->binding_label
981 && (!gsym
->binding_label
982 || strcmp (common_root
->n
.common
->binding_label
,
983 gsym
->binding_label
) != 0))
984 || (!common_root
->n
.common
->binding_label
985 && gsym
->binding_label
)))
987 gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
988 "identifier and must thus have the same binding name "
989 "as the same-named COMMON block at %L: %s vs %s",
990 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
992 common_root
->n
.common
->binding_label
993 ? common_root
->n
.common
->binding_label
: "(blank)",
994 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
998 if (gsym
&& gsym
->type
!= GSYM_COMMON
999 && !common_root
->n
.common
->binding_label
)
1001 gfc_error ("COMMON block '%s' at %L uses the same global identifier "
1003 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1007 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1009 gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
1010 "%L sharing the identifier with global non-COMMON-block "
1011 "entity at %L", common_root
->n
.common
->name
,
1012 &common_root
->n
.common
->where
, &gsym
->where
);
1017 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1018 gsym
->type
= GSYM_COMMON
;
1019 gsym
->where
= common_root
->n
.common
->where
;
1025 if (common_root
->n
.common
->binding_label
)
1027 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1028 common_root
->n
.common
->binding_label
);
1029 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1031 gfc_error ("COMMON block at %L with binding label %s uses the same "
1032 "global identifier as entity at %L",
1033 &common_root
->n
.common
->where
,
1034 common_root
->n
.common
->binding_label
, &gsym
->where
);
1039 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1040 gsym
->type
= GSYM_COMMON
;
1041 gsym
->where
= common_root
->n
.common
->where
;
1047 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1051 if (sym
->attr
.flavor
== FL_PARAMETER
)
1052 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
1053 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1055 if (sym
->attr
.external
)
1056 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
1057 sym
->name
, &common_root
->n
.common
->where
);
1059 if (sym
->attr
.intrinsic
)
1060 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
1061 sym
->name
, &common_root
->n
.common
->where
);
1062 else if (sym
->attr
.result
1063 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1064 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1065 "that is also a function result", sym
->name
,
1066 &common_root
->n
.common
->where
);
1067 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1068 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1069 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1070 "that is also a global procedure", sym
->name
,
1071 &common_root
->n
.common
->where
);
1075 /* Resolve contained function types. Because contained functions can call one
1076 another, they have to be worked out before any of the contained procedures
1079 The good news is that if a function doesn't already have a type, the only
1080 way it can get one is through an IMPLICIT type or a RESULT variable, because
1081 by definition contained functions are contained namespace they're contained
1082 in, not in a sibling or parent namespace. */
1085 resolve_contained_functions (gfc_namespace
*ns
)
1087 gfc_namespace
*child
;
1090 resolve_formal_arglists (ns
);
1092 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1094 /* Resolve alternate entry points first. */
1095 resolve_entries (child
);
1097 /* Then check function return types. */
1098 resolve_contained_fntype (child
->proc_name
, child
);
1099 for (el
= child
->entries
; el
; el
= el
->next
)
1100 resolve_contained_fntype (el
->sym
, child
);
1105 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1108 /* Resolve all of the elements of a structure constructor and make sure that
1109 the types are correct. The 'init' flag indicates that the given
1110 constructor is an initializer. */
1113 resolve_structure_cons (gfc_expr
*expr
, int init
)
1115 gfc_constructor
*cons
;
1116 gfc_component
*comp
;
1122 if (expr
->ts
.type
== BT_DERIVED
)
1123 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1125 cons
= gfc_constructor_first (expr
->value
.constructor
);
1127 /* A constructor may have references if it is the result of substituting a
1128 parameter variable. In this case we just pull out the component we
1131 comp
= expr
->ref
->u
.c
.sym
->components
;
1133 comp
= expr
->ts
.u
.derived
->components
;
1135 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1142 if (!gfc_resolve_expr (cons
->expr
))
1148 rank
= comp
->as
? comp
->as
->rank
: 0;
1149 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1150 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1152 gfc_error ("The rank of the element in the structure "
1153 "constructor at %L does not match that of the "
1154 "component (%d/%d)", &cons
->expr
->where
,
1155 cons
->expr
->rank
, rank
);
1159 /* If we don't have the right type, try to convert it. */
1161 if (!comp
->attr
.proc_pointer
&&
1162 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1164 if (strcmp (comp
->name
, "_extends") == 0)
1166 /* Can afford to be brutal with the _extends initializer.
1167 The derived type can get lost because it is PRIVATE
1168 but it is not usage constrained by the standard. */
1169 cons
->expr
->ts
= comp
->ts
;
1171 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1173 gfc_error ("The element in the structure constructor at %L, "
1174 "for pointer component '%s', is %s but should be %s",
1175 &cons
->expr
->where
, comp
->name
,
1176 gfc_basic_typename (cons
->expr
->ts
.type
),
1177 gfc_basic_typename (comp
->ts
.type
));
1182 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1188 /* For strings, the length of the constructor should be the same as
1189 the one of the structure, ensure this if the lengths are known at
1190 compile time and when we are dealing with PARAMETER or structure
1192 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1193 && comp
->ts
.u
.cl
->length
1194 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1195 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1196 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1197 && cons
->expr
->rank
!= 0
1198 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1199 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1201 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1202 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1204 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1205 to make use of the gfc_resolve_character_array_constructor
1206 machinery. The expression is later simplified away to
1207 an array of string literals. */
1208 gfc_expr
*para
= cons
->expr
;
1209 cons
->expr
= gfc_get_expr ();
1210 cons
->expr
->ts
= para
->ts
;
1211 cons
->expr
->where
= para
->where
;
1212 cons
->expr
->expr_type
= EXPR_ARRAY
;
1213 cons
->expr
->rank
= para
->rank
;
1214 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1215 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1216 para
, &cons
->expr
->where
);
1218 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1221 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1222 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1224 gfc_charlen
*cl
, *cl2
;
1227 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1229 if (cl
== cons
->expr
->ts
.u
.cl
)
1237 cl2
->next
= cl
->next
;
1239 gfc_free_expr (cl
->length
);
1243 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1244 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1245 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1246 gfc_resolve_character_array_constructor (cons
->expr
);
1250 if (cons
->expr
->expr_type
== EXPR_NULL
1251 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1252 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1253 || (comp
->ts
.type
== BT_CLASS
1254 && (CLASS_DATA (comp
)->attr
.class_pointer
1255 || CLASS_DATA (comp
)->attr
.allocatable
))))
1258 gfc_error ("The NULL in the structure constructor at %L is "
1259 "being applied to component '%s', which is neither "
1260 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1264 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1266 /* Check procedure pointer interface. */
1267 gfc_symbol
*s2
= NULL
;
1272 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1275 s2
= c2
->ts
.interface
;
1278 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1280 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1281 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1283 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1285 s2
= cons
->expr
->symtree
->n
.sym
;
1286 name
= cons
->expr
->symtree
->n
.sym
->name
;
1289 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1290 err
, sizeof (err
), NULL
, NULL
))
1292 gfc_error ("Interface mismatch for procedure-pointer component "
1293 "'%s' in structure constructor at %L: %s",
1294 comp
->name
, &cons
->expr
->where
, err
);
1299 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1300 || cons
->expr
->expr_type
== EXPR_NULL
)
1303 a
= gfc_expr_attr (cons
->expr
);
1305 if (!a
.pointer
&& !a
.target
)
1308 gfc_error ("The element in the structure constructor at %L, "
1309 "for pointer component '%s' should be a POINTER or "
1310 "a TARGET", &cons
->expr
->where
, comp
->name
);
1315 /* F08:C461. Additional checks for pointer initialization. */
1319 gfc_error ("Pointer initialization target at %L "
1320 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1325 gfc_error ("Pointer initialization target at %L "
1326 "must have the SAVE attribute", &cons
->expr
->where
);
1330 /* F2003, C1272 (3). */
1331 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1332 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1333 || gfc_is_coindexed (cons
->expr
)))
1336 gfc_error ("Invalid expression in the structure constructor for "
1337 "pointer component '%s' at %L in PURE procedure",
1338 comp
->name
, &cons
->expr
->where
);
1341 if (gfc_implicit_pure (NULL
)
1342 && cons
->expr
->expr_type
== EXPR_VARIABLE
1343 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1344 || gfc_is_coindexed (cons
->expr
)))
1345 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1353 /****************** Expression name resolution ******************/
1355 /* Returns 0 if a symbol was not declared with a type or
1356 attribute declaration statement, nonzero otherwise. */
1359 was_declared (gfc_symbol
*sym
)
1365 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1368 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1369 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1370 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1371 || a
.asynchronous
|| a
.codimension
)
1378 /* Determine if a symbol is generic or not. */
1381 generic_sym (gfc_symbol
*sym
)
1385 if (sym
->attr
.generic
||
1386 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1389 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1392 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1399 return generic_sym (s
);
1406 /* Determine if a symbol is specific or not. */
1409 specific_sym (gfc_symbol
*sym
)
1413 if (sym
->attr
.if_source
== IFSRC_IFBODY
1414 || sym
->attr
.proc
== PROC_MODULE
1415 || sym
->attr
.proc
== PROC_INTERNAL
1416 || sym
->attr
.proc
== PROC_ST_FUNCTION
1417 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1418 || sym
->attr
.external
)
1421 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1424 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1426 return (s
== NULL
) ? 0 : specific_sym (s
);
1430 /* Figure out if the procedure is specific, generic or unknown. */
1433 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1437 procedure_kind (gfc_symbol
*sym
)
1439 if (generic_sym (sym
))
1440 return PTYPE_GENERIC
;
1442 if (specific_sym (sym
))
1443 return PTYPE_SPECIFIC
;
1445 return PTYPE_UNKNOWN
;
1448 /* Check references to assumed size arrays. The flag need_full_assumed_size
1449 is nonzero when matching actual arguments. */
1451 static int need_full_assumed_size
= 0;
1454 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1456 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1459 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1460 What should it be? */
1461 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1462 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1463 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1465 gfc_error ("The upper bound in the last dimension must "
1466 "appear in the reference to the assumed size "
1467 "array '%s' at %L", sym
->name
, &e
->where
);
1474 /* Look for bad assumed size array references in argument expressions
1475 of elemental and array valued intrinsic procedures. Since this is
1476 called from procedure resolution functions, it only recurses at
1480 resolve_assumed_size_actual (gfc_expr
*e
)
1485 switch (e
->expr_type
)
1488 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1493 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1494 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1505 /* Check a generic procedure, passed as an actual argument, to see if
1506 there is a matching specific name. If none, it is an error, and if
1507 more than one, the reference is ambiguous. */
1509 count_specific_procs (gfc_expr
*e
)
1516 sym
= e
->symtree
->n
.sym
;
1518 for (p
= sym
->generic
; p
; p
= p
->next
)
1519 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1521 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1527 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1531 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1532 "argument at %L", sym
->name
, &e
->where
);
1538 /* See if a call to sym could possibly be a not allowed RECURSION because of
1539 a missing RECURSIVE declaration. This means that either sym is the current
1540 context itself, or sym is the parent of a contained procedure calling its
1541 non-RECURSIVE containing procedure.
1542 This also works if sym is an ENTRY. */
1545 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1547 gfc_symbol
* proc_sym
;
1548 gfc_symbol
* context_proc
;
1549 gfc_namespace
* real_context
;
1551 if (sym
->attr
.flavor
== FL_PROGRAM
1552 || sym
->attr
.flavor
== FL_DERIVED
)
1555 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1557 /* If we've got an ENTRY, find real procedure. */
1558 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1559 proc_sym
= sym
->ns
->entries
->sym
;
1563 /* If sym is RECURSIVE, all is well of course. */
1564 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1567 /* Find the context procedure's "real" symbol if it has entries.
1568 We look for a procedure symbol, so recurse on the parents if we don't
1569 find one (like in case of a BLOCK construct). */
1570 for (real_context
= context
; ; real_context
= real_context
->parent
)
1572 /* We should find something, eventually! */
1573 gcc_assert (real_context
);
1575 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1576 : real_context
->proc_name
);
1578 /* In some special cases, there may not be a proc_name, like for this
1580 real(bad_kind()) function foo () ...
1581 when checking the call to bad_kind ().
1582 In these cases, we simply return here and assume that the
1587 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1591 /* A call from sym's body to itself is recursion, of course. */
1592 if (context_proc
== proc_sym
)
1595 /* The same is true if context is a contained procedure and sym the
1597 if (context_proc
->attr
.contained
)
1599 gfc_symbol
* parent_proc
;
1601 gcc_assert (context
->parent
);
1602 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1603 : context
->parent
->proc_name
);
1605 if (parent_proc
== proc_sym
)
1613 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1614 its typespec and formal argument list. */
1617 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1619 gfc_intrinsic_sym
* isym
= NULL
;
1625 /* Already resolved. */
1626 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1629 /* We already know this one is an intrinsic, so we don't call
1630 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1631 gfc_find_subroutine directly to check whether it is a function or
1634 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1636 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1637 isym
= gfc_intrinsic_subroutine_by_id (id
);
1639 else if (sym
->intmod_sym_id
)
1641 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1642 isym
= gfc_intrinsic_function_by_id (id
);
1644 else if (!sym
->attr
.subroutine
)
1645 isym
= gfc_find_function (sym
->name
);
1647 if (isym
&& !sym
->attr
.subroutine
)
1649 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1650 && !sym
->attr
.implicit_type
)
1651 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1652 " ignored", sym
->name
, &sym
->declared_at
);
1654 if (!sym
->attr
.function
&&
1655 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1660 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1662 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1664 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1665 " specifier", sym
->name
, &sym
->declared_at
);
1669 if (!sym
->attr
.subroutine
&&
1670 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1675 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1680 gfc_copy_formal_args_intr (sym
, isym
);
1682 sym
->attr
.pure
= isym
->pure
;
1683 sym
->attr
.elemental
= isym
->elemental
;
1685 /* Check it is actually available in the standard settings. */
1686 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1688 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1689 " available in the current standard settings but %s. Use"
1690 " an appropriate -std=* option or enable -fall-intrinsics"
1691 " in order to use it.",
1692 sym
->name
, &sym
->declared_at
, symstd
);
1700 /* Resolve a procedure expression, like passing it to a called procedure or as
1701 RHS for a procedure pointer assignment. */
1704 resolve_procedure_expression (gfc_expr
* expr
)
1708 if (expr
->expr_type
!= EXPR_VARIABLE
)
1710 gcc_assert (expr
->symtree
);
1712 sym
= expr
->symtree
->n
.sym
;
1714 if (sym
->attr
.intrinsic
)
1715 gfc_resolve_intrinsic (sym
, &expr
->where
);
1717 if (sym
->attr
.flavor
!= FL_PROCEDURE
1718 || (sym
->attr
.function
&& sym
->result
== sym
))
1721 /* A non-RECURSIVE procedure that is used as procedure expression within its
1722 own body is in danger of being called recursively. */
1723 if (is_illegal_recursion (sym
, gfc_current_ns
))
1724 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1725 " itself recursively. Declare it RECURSIVE or use"
1726 " -frecursive", sym
->name
, &expr
->where
);
1732 /* Resolve an actual argument list. Most of the time, this is just
1733 resolving the expressions in the list.
1734 The exception is that we sometimes have to decide whether arguments
1735 that look like procedure arguments are really simple variable
1739 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1740 bool no_formal_args
)
1743 gfc_symtree
*parent_st
;
1745 int save_need_full_assumed_size
;
1746 bool return_value
= false;
1747 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1750 first_actual_arg
= true;
1752 for (; arg
; arg
= arg
->next
)
1757 /* Check the label is a valid branching target. */
1760 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1762 gfc_error ("Label %d referenced at %L is never defined",
1763 arg
->label
->value
, &arg
->label
->where
);
1767 first_actual_arg
= false;
1771 if (e
->expr_type
== EXPR_VARIABLE
1772 && e
->symtree
->n
.sym
->attr
.generic
1774 && count_specific_procs (e
) != 1)
1777 if (e
->ts
.type
!= BT_PROCEDURE
)
1779 save_need_full_assumed_size
= need_full_assumed_size
;
1780 if (e
->expr_type
!= EXPR_VARIABLE
)
1781 need_full_assumed_size
= 0;
1782 if (!gfc_resolve_expr (e
))
1784 need_full_assumed_size
= save_need_full_assumed_size
;
1788 /* See if the expression node should really be a variable reference. */
1790 sym
= e
->symtree
->n
.sym
;
1792 if (sym
->attr
.flavor
== FL_PROCEDURE
1793 || sym
->attr
.intrinsic
1794 || sym
->attr
.external
)
1798 /* If a procedure is not already determined to be something else
1799 check if it is intrinsic. */
1800 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1801 sym
->attr
.intrinsic
= 1;
1803 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1805 gfc_error ("Statement function '%s' at %L is not allowed as an "
1806 "actual argument", sym
->name
, &e
->where
);
1809 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1810 sym
->attr
.subroutine
);
1811 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1813 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1814 "actual argument", sym
->name
, &e
->where
);
1817 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1818 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1820 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is"
1821 " used as actual argument at %L",
1822 sym
->name
, &e
->where
))
1826 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1828 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1829 "allowed as an actual argument at %L", sym
->name
,
1833 /* Check if a generic interface has a specific procedure
1834 with the same name before emitting an error. */
1835 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1838 /* Just in case a specific was found for the expression. */
1839 sym
= e
->symtree
->n
.sym
;
1841 /* If the symbol is the function that names the current (or
1842 parent) scope, then we really have a variable reference. */
1844 if (gfc_is_function_return_value (sym
, sym
->ns
))
1847 /* If all else fails, see if we have a specific intrinsic. */
1848 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1850 gfc_intrinsic_sym
*isym
;
1852 isym
= gfc_find_function (sym
->name
);
1853 if (isym
== NULL
|| !isym
->specific
)
1855 gfc_error ("Unable to find a specific INTRINSIC procedure "
1856 "for the reference '%s' at %L", sym
->name
,
1861 sym
->attr
.intrinsic
= 1;
1862 sym
->attr
.function
= 1;
1865 if (!gfc_resolve_expr (e
))
1870 /* See if the name is a module procedure in a parent unit. */
1872 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1875 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1877 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1881 if (parent_st
== NULL
)
1884 sym
= parent_st
->n
.sym
;
1885 e
->symtree
= parent_st
; /* Point to the right thing. */
1887 if (sym
->attr
.flavor
== FL_PROCEDURE
1888 || sym
->attr
.intrinsic
1889 || sym
->attr
.external
)
1891 if (!gfc_resolve_expr (e
))
1897 e
->expr_type
= EXPR_VARIABLE
;
1899 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1900 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1901 && CLASS_DATA (sym
)->as
))
1903 e
->rank
= sym
->ts
.type
== BT_CLASS
1904 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1905 e
->ref
= gfc_get_ref ();
1906 e
->ref
->type
= REF_ARRAY
;
1907 e
->ref
->u
.ar
.type
= AR_FULL
;
1908 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1909 ? CLASS_DATA (sym
)->as
: sym
->as
;
1912 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1913 primary.c (match_actual_arg). If above code determines that it
1914 is a variable instead, it needs to be resolved as it was not
1915 done at the beginning of this function. */
1916 save_need_full_assumed_size
= need_full_assumed_size
;
1917 if (e
->expr_type
!= EXPR_VARIABLE
)
1918 need_full_assumed_size
= 0;
1919 if (!gfc_resolve_expr (e
))
1921 need_full_assumed_size
= save_need_full_assumed_size
;
1924 /* Check argument list functions %VAL, %LOC and %REF. There is
1925 nothing to do for %REF. */
1926 if (arg
->name
&& arg
->name
[0] == '%')
1928 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1930 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1932 gfc_error ("By-value argument at %L is not of numeric "
1939 gfc_error ("By-value argument at %L cannot be an array or "
1940 "an array section", &e
->where
);
1944 /* Intrinsics are still PROC_UNKNOWN here. However,
1945 since same file external procedures are not resolvable
1946 in gfortran, it is a good deal easier to leave them to
1948 if (ptype
!= PROC_UNKNOWN
1949 && ptype
!= PROC_DUMMY
1950 && ptype
!= PROC_EXTERNAL
1951 && ptype
!= PROC_MODULE
)
1953 gfc_error ("By-value argument at %L is not allowed "
1954 "in this context", &e
->where
);
1959 /* Statement functions have already been excluded above. */
1960 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1961 && e
->ts
.type
== BT_PROCEDURE
)
1963 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1965 gfc_error ("Passing internal procedure at %L by location "
1966 "not allowed", &e
->where
);
1972 /* Fortran 2008, C1237. */
1973 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1974 && gfc_has_ultimate_pointer (e
))
1976 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1977 "component", &e
->where
);
1981 first_actual_arg
= false;
1984 return_value
= true;
1987 actual_arg
= actual_arg_sav
;
1988 first_actual_arg
= first_actual_arg_sav
;
1990 return return_value
;
1994 /* Do the checks of the actual argument list that are specific to elemental
1995 procedures. If called with c == NULL, we have a function, otherwise if
1996 expr == NULL, we have a subroutine. */
1999 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2001 gfc_actual_arglist
*arg0
;
2002 gfc_actual_arglist
*arg
;
2003 gfc_symbol
*esym
= NULL
;
2004 gfc_intrinsic_sym
*isym
= NULL
;
2006 gfc_intrinsic_arg
*iformal
= NULL
;
2007 gfc_formal_arglist
*eformal
= NULL
;
2008 bool formal_optional
= false;
2009 bool set_by_optional
= false;
2013 /* Is this an elemental procedure? */
2014 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2016 if (expr
->value
.function
.esym
!= NULL
2017 && expr
->value
.function
.esym
->attr
.elemental
)
2019 arg0
= expr
->value
.function
.actual
;
2020 esym
= expr
->value
.function
.esym
;
2022 else if (expr
->value
.function
.isym
!= NULL
2023 && expr
->value
.function
.isym
->elemental
)
2025 arg0
= expr
->value
.function
.actual
;
2026 isym
= expr
->value
.function
.isym
;
2031 else if (c
&& c
->ext
.actual
!= NULL
)
2033 arg0
= c
->ext
.actual
;
2035 if (c
->resolved_sym
)
2036 esym
= c
->resolved_sym
;
2038 esym
= c
->symtree
->n
.sym
;
2041 if (!esym
->attr
.elemental
)
2047 /* The rank of an elemental is the rank of its array argument(s). */
2048 for (arg
= arg0
; arg
; arg
= arg
->next
)
2050 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2052 rank
= arg
->expr
->rank
;
2053 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2054 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2055 set_by_optional
= true;
2057 /* Function specific; set the result rank and shape. */
2061 if (!expr
->shape
&& arg
->expr
->shape
)
2063 expr
->shape
= gfc_get_shape (rank
);
2064 for (i
= 0; i
< rank
; i
++)
2065 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2072 /* If it is an array, it shall not be supplied as an actual argument
2073 to an elemental procedure unless an array of the same rank is supplied
2074 as an actual argument corresponding to a nonoptional dummy argument of
2075 that elemental procedure(12.4.1.5). */
2076 formal_optional
= false;
2078 iformal
= isym
->formal
;
2080 eformal
= esym
->formal
;
2082 for (arg
= arg0
; arg
; arg
= arg
->next
)
2086 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2087 formal_optional
= true;
2088 eformal
= eformal
->next
;
2090 else if (isym
&& iformal
)
2092 if (iformal
->optional
)
2093 formal_optional
= true;
2094 iformal
= iformal
->next
;
2097 formal_optional
= true;
2099 if (pedantic
&& arg
->expr
!= NULL
2100 && arg
->expr
->expr_type
== EXPR_VARIABLE
2101 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2104 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2105 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2107 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2108 "MISSING, it cannot be the actual argument of an "
2109 "ELEMENTAL procedure unless there is a non-optional "
2110 "argument with the same rank (12.4.1.5)",
2111 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2115 for (arg
= arg0
; arg
; arg
= arg
->next
)
2117 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2120 /* Being elemental, the last upper bound of an assumed size array
2121 argument must be present. */
2122 if (resolve_assumed_size_actual (arg
->expr
))
2125 /* Elemental procedure's array actual arguments must conform. */
2128 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2135 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2136 is an array, the intent inout/out variable needs to be also an array. */
2137 if (rank
> 0 && esym
&& expr
== NULL
)
2138 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2139 arg
= arg
->next
, eformal
= eformal
->next
)
2140 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2141 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2142 && arg
->expr
&& arg
->expr
->rank
== 0)
2144 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2145 "ELEMENTAL subroutine '%s' is a scalar, but another "
2146 "actual argument is an array", &arg
->expr
->where
,
2147 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2148 : "INOUT", eformal
->sym
->name
, esym
->name
);
2155 /* This function does the checking of references to global procedures
2156 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2157 77 and 95 standards. It checks for a gsymbol for the name, making
2158 one if it does not already exist. If it already exists, then the
2159 reference being resolved must correspond to the type of gsymbol.
2160 Otherwise, the new symbol is equipped with the attributes of the
2161 reference. The corresponding code that is called in creating
2162 global entities is parse.c.
2164 In addition, for all but -std=legacy, the gsymbols are used to
2165 check the interfaces of external procedures from the same file.
2166 The namespace of the gsymbol is resolved and then, once this is
2167 done the interface is checked. */
2171 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2173 if (!gsym_ns
->proc_name
->attr
.recursive
)
2176 if (sym
->ns
== gsym_ns
)
2179 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2186 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2188 if (gsym_ns
->entries
)
2190 gfc_entry_list
*entry
= gsym_ns
->entries
;
2192 for (; entry
; entry
= entry
->next
)
2194 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2196 if (strcmp (gsym_ns
->proc_name
->name
,
2197 sym
->ns
->proc_name
->name
) == 0)
2201 && strcmp (gsym_ns
->proc_name
->name
,
2202 sym
->ns
->parent
->proc_name
->name
) == 0)
2211 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2214 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2216 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2218 for ( ; arg
; arg
= arg
->next
)
2223 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2225 strncpy (errmsg
, _("allocatable argument"), err_len
);
2228 else if (arg
->sym
->attr
.asynchronous
)
2230 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2233 else if (arg
->sym
->attr
.optional
)
2235 strncpy (errmsg
, _("optional argument"), err_len
);
2238 else if (arg
->sym
->attr
.pointer
)
2240 strncpy (errmsg
, _("pointer argument"), err_len
);
2243 else if (arg
->sym
->attr
.target
)
2245 strncpy (errmsg
, _("target argument"), err_len
);
2248 else if (arg
->sym
->attr
.value
)
2250 strncpy (errmsg
, _("value argument"), err_len
);
2253 else if (arg
->sym
->attr
.volatile_
)
2255 strncpy (errmsg
, _("volatile argument"), err_len
);
2258 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2260 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2263 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2265 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2268 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2270 strncpy (errmsg
, _("coarray argument"), err_len
);
2273 else if (false) /* (2d) TODO: parametrized derived type */
2275 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2278 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2280 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2283 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2285 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2288 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2290 /* As assumed-type is unlimited polymorphic (cf. above).
2291 See also TS 29113, Note 6.1. */
2292 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2297 if (sym
->attr
.function
)
2299 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2301 if (res
->attr
.dimension
) /* (3a) */
2303 strncpy (errmsg
, _("array result"), err_len
);
2306 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2308 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2311 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2312 && res
->ts
.u
.cl
->length
2313 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2315 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2320 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2322 strncpy (errmsg
, _("elemental procedure"), err_len
);
2325 else if (sym
->attr
.is_bind_c
) /* (5) */
2327 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2336 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2337 gfc_actual_arglist
**actual
, int sub
)
2341 enum gfc_symbol_type type
;
2344 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2346 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2348 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2349 gfc_global_used (gsym
, where
);
2351 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2352 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2353 && gsym
->type
!= GSYM_UNKNOWN
2355 && gsym
->ns
->resolved
!= -1
2356 && gsym
->ns
->proc_name
2357 && not_in_recursive (sym
, gsym
->ns
)
2358 && not_entry_self_reference (sym
, gsym
->ns
))
2360 gfc_symbol
*def_sym
;
2362 /* Resolve the gsymbol namespace if needed. */
2363 if (!gsym
->ns
->resolved
)
2365 gfc_dt_list
*old_dt_list
;
2366 struct gfc_omp_saved_state old_omp_state
;
2368 /* Stash away derived types so that the backend_decls do not
2370 old_dt_list
= gfc_derived_types
;
2371 gfc_derived_types
= NULL
;
2372 /* And stash away openmp state. */
2373 gfc_omp_save_and_clear_state (&old_omp_state
);
2375 gfc_resolve (gsym
->ns
);
2377 /* Store the new derived types with the global namespace. */
2378 if (gfc_derived_types
)
2379 gsym
->ns
->derived_types
= gfc_derived_types
;
2381 /* Restore the derived types of this namespace. */
2382 gfc_derived_types
= old_dt_list
;
2383 /* And openmp state. */
2384 gfc_omp_restore_state (&old_omp_state
);
2387 /* Make sure that translation for the gsymbol occurs before
2388 the procedure currently being resolved. */
2389 ns
= gfc_global_ns_list
;
2390 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2392 if (ns
->sibling
== gsym
->ns
)
2394 ns
->sibling
= gsym
->ns
->sibling
;
2395 gsym
->ns
->sibling
= gfc_global_ns_list
;
2396 gfc_global_ns_list
= gsym
->ns
;
2401 def_sym
= gsym
->ns
->proc_name
;
2403 /* This can happen if a binding name has been specified. */
2404 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2405 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2407 if (def_sym
->attr
.entry_master
)
2409 gfc_entry_list
*entry
;
2410 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2411 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2413 def_sym
= entry
->sym
;
2418 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2420 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2421 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2422 gfc_typename (&def_sym
->ts
));
2426 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2427 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2429 gfc_error ("Explicit interface required for '%s' at %L: %s",
2430 sym
->name
, &sym
->declared_at
, reason
);
2434 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2435 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2436 gfc_errors_to_warnings (1);
2438 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2439 reason
, sizeof(reason
), NULL
, NULL
))
2441 gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
2442 sym
->name
, &sym
->declared_at
, reason
);
2447 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2448 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2449 gfc_errors_to_warnings (1);
2451 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2452 gfc_procedure_use (def_sym
, actual
, where
);
2456 gfc_errors_to_warnings (0);
2458 if (gsym
->type
== GSYM_UNKNOWN
)
2461 gsym
->where
= *where
;
2468 /************* Function resolution *************/
2470 /* Resolve a function call known to be generic.
2471 Section 14.1.2.4.1. */
2474 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2478 if (sym
->attr
.generic
)
2480 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2483 expr
->value
.function
.name
= s
->name
;
2484 expr
->value
.function
.esym
= s
;
2486 if (s
->ts
.type
!= BT_UNKNOWN
)
2488 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2489 expr
->ts
= s
->result
->ts
;
2492 expr
->rank
= s
->as
->rank
;
2493 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2494 expr
->rank
= s
->result
->as
->rank
;
2496 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2501 /* TODO: Need to search for elemental references in generic
2505 if (sym
->attr
.intrinsic
)
2506 return gfc_intrinsic_func_interface (expr
, 0);
2513 resolve_generic_f (gfc_expr
*expr
)
2517 gfc_interface
*intr
= NULL
;
2519 sym
= expr
->symtree
->n
.sym
;
2523 m
= resolve_generic_f0 (expr
, sym
);
2526 else if (m
== MATCH_ERROR
)
2531 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2532 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2535 if (sym
->ns
->parent
== NULL
)
2537 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2541 if (!generic_sym (sym
))
2545 /* Last ditch attempt. See if the reference is to an intrinsic
2546 that possesses a matching interface. 14.1.2.4 */
2547 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2549 gfc_error ("There is no specific function for the generic '%s' "
2550 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2556 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2559 return resolve_structure_cons (expr
, 0);
2562 m
= gfc_intrinsic_func_interface (expr
, 0);
2567 gfc_error ("Generic function '%s' at %L is not consistent with a "
2568 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2575 /* Resolve a function call known to be specific. */
2578 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2582 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2584 if (sym
->attr
.dummy
)
2586 sym
->attr
.proc
= PROC_DUMMY
;
2590 sym
->attr
.proc
= PROC_EXTERNAL
;
2594 if (sym
->attr
.proc
== PROC_MODULE
2595 || sym
->attr
.proc
== PROC_ST_FUNCTION
2596 || sym
->attr
.proc
== PROC_INTERNAL
)
2599 if (sym
->attr
.intrinsic
)
2601 m
= gfc_intrinsic_func_interface (expr
, 1);
2605 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2606 "with an intrinsic", sym
->name
, &expr
->where
);
2614 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2617 expr
->ts
= sym
->result
->ts
;
2620 expr
->value
.function
.name
= sym
->name
;
2621 expr
->value
.function
.esym
= sym
;
2622 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2623 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2624 else if (sym
->as
!= NULL
)
2625 expr
->rank
= sym
->as
->rank
;
2632 resolve_specific_f (gfc_expr
*expr
)
2637 sym
= expr
->symtree
->n
.sym
;
2641 m
= resolve_specific_f0 (sym
, expr
);
2644 if (m
== MATCH_ERROR
)
2647 if (sym
->ns
->parent
== NULL
)
2650 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2656 gfc_error ("Unable to resolve the specific function '%s' at %L",
2657 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2663 /* Resolve a procedure call not known to be generic nor specific. */
2666 resolve_unknown_f (gfc_expr
*expr
)
2671 sym
= expr
->symtree
->n
.sym
;
2673 if (sym
->attr
.dummy
)
2675 sym
->attr
.proc
= PROC_DUMMY
;
2676 expr
->value
.function
.name
= sym
->name
;
2680 /* See if we have an intrinsic function reference. */
2682 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2684 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2689 /* The reference is to an external name. */
2691 sym
->attr
.proc
= PROC_EXTERNAL
;
2692 expr
->value
.function
.name
= sym
->name
;
2693 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2695 if (sym
->as
!= NULL
)
2696 expr
->rank
= sym
->as
->rank
;
2698 /* Type of the expression is either the type of the symbol or the
2699 default type of the symbol. */
2702 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2704 if (sym
->ts
.type
!= BT_UNKNOWN
)
2708 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2710 if (ts
->type
== BT_UNKNOWN
)
2712 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2713 sym
->name
, &expr
->where
);
2724 /* Return true, if the symbol is an external procedure. */
2726 is_external_proc (gfc_symbol
*sym
)
2728 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2729 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2730 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2731 && !sym
->attr
.proc_pointer
2732 && !sym
->attr
.use_assoc
2740 /* Figure out if a function reference is pure or not. Also set the name
2741 of the function for a potential error message. Return nonzero if the
2742 function is PURE, zero if not. */
2744 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2747 pure_function (gfc_expr
*e
, const char **name
)
2753 if (e
->symtree
!= NULL
2754 && e
->symtree
->n
.sym
!= NULL
2755 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2756 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2758 if (e
->value
.function
.esym
)
2760 pure
= gfc_pure (e
->value
.function
.esym
);
2761 *name
= e
->value
.function
.esym
->name
;
2763 else if (e
->value
.function
.isym
)
2765 pure
= e
->value
.function
.isym
->pure
2766 || e
->value
.function
.isym
->elemental
;
2767 *name
= e
->value
.function
.isym
->name
;
2771 /* Implicit functions are not pure. */
2773 *name
= e
->value
.function
.name
;
2781 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2782 int *f ATTRIBUTE_UNUSED
)
2786 /* Don't bother recursing into other statement functions
2787 since they will be checked individually for purity. */
2788 if (e
->expr_type
!= EXPR_FUNCTION
2790 || e
->symtree
->n
.sym
== sym
2791 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2794 return pure_function (e
, &name
) ? false : true;
2799 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2801 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2805 /* Resolve a function call, which means resolving the arguments, then figuring
2806 out which entity the name refers to. */
2809 resolve_function (gfc_expr
*expr
)
2811 gfc_actual_arglist
*arg
;
2816 procedure_type p
= PROC_INTRINSIC
;
2817 bool no_formal_args
;
2821 sym
= expr
->symtree
->n
.sym
;
2823 /* If this is a procedure pointer component, it has already been resolved. */
2824 if (gfc_is_proc_ptr_comp (expr
))
2827 if (sym
&& sym
->attr
.intrinsic
2828 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2831 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2833 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2837 /* If this ia a deferred TBP with an abstract interface (which may
2838 of course be referenced), expr->value.function.esym will be set. */
2839 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2841 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2842 sym
->name
, &expr
->where
);
2846 /* Switch off assumed size checking and do this again for certain kinds
2847 of procedure, once the procedure itself is resolved. */
2848 need_full_assumed_size
++;
2850 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2851 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2853 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2854 inquiry_argument
= true;
2855 no_formal_args
= sym
&& is_external_proc (sym
)
2856 && gfc_sym_get_dummy_args (sym
) == NULL
;
2858 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2861 inquiry_argument
= false;
2865 inquiry_argument
= false;
2867 /* Resume assumed_size checking. */
2868 need_full_assumed_size
--;
2870 /* If the procedure is external, check for usage. */
2871 if (sym
&& is_external_proc (sym
))
2872 resolve_global_procedure (sym
, &expr
->where
,
2873 &expr
->value
.function
.actual
, 0);
2875 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2877 && sym
->ts
.u
.cl
->length
== NULL
2879 && !sym
->ts
.deferred
2880 && expr
->value
.function
.esym
== NULL
2881 && !sym
->attr
.contained
)
2883 /* Internal procedures are taken care of in resolve_contained_fntype. */
2884 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2885 "be used at %L since it is not a dummy argument",
2886 sym
->name
, &expr
->where
);
2890 /* See if function is already resolved. */
2892 if (expr
->value
.function
.name
!= NULL
)
2894 if (expr
->ts
.type
== BT_UNKNOWN
)
2900 /* Apply the rules of section 14.1.2. */
2902 switch (procedure_kind (sym
))
2905 t
= resolve_generic_f (expr
);
2908 case PTYPE_SPECIFIC
:
2909 t
= resolve_specific_f (expr
);
2913 t
= resolve_unknown_f (expr
);
2917 gfc_internal_error ("resolve_function(): bad function type");
2921 /* If the expression is still a function (it might have simplified),
2922 then we check to see if we are calling an elemental function. */
2924 if (expr
->expr_type
!= EXPR_FUNCTION
)
2927 temp
= need_full_assumed_size
;
2928 need_full_assumed_size
= 0;
2930 if (!resolve_elemental_actual (expr
, NULL
))
2933 if (omp_workshare_flag
2934 && expr
->value
.function
.esym
2935 && ! gfc_elemental (expr
->value
.function
.esym
))
2937 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2938 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2943 #define GENERIC_ID expr->value.function.isym->id
2944 else if (expr
->value
.function
.actual
!= NULL
2945 && expr
->value
.function
.isym
!= NULL
2946 && GENERIC_ID
!= GFC_ISYM_LBOUND
2947 && GENERIC_ID
!= GFC_ISYM_LEN
2948 && GENERIC_ID
!= GFC_ISYM_LOC
2949 && GENERIC_ID
!= GFC_ISYM_C_LOC
2950 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2952 /* Array intrinsics must also have the last upper bound of an
2953 assumed size array argument. UBOUND and SIZE have to be
2954 excluded from the check if the second argument is anything
2957 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2959 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2960 && arg
== expr
->value
.function
.actual
2961 && arg
->next
!= NULL
&& arg
->next
->expr
)
2963 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2966 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2969 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2974 if (arg
->expr
!= NULL
2975 && arg
->expr
->rank
> 0
2976 && resolve_assumed_size_actual (arg
->expr
))
2982 need_full_assumed_size
= temp
;
2985 if (!pure_function (expr
, &name
) && name
)
2989 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2990 "FORALL %s", name
, &expr
->where
,
2991 forall_flag
== 2 ? "mask" : "block");
2994 else if (gfc_do_concurrent_flag
)
2996 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2997 "DO CONCURRENT %s", name
, &expr
->where
,
2998 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3001 else if (gfc_pure (NULL
))
3003 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3004 "procedure within a PURE procedure", name
, &expr
->where
);
3008 if (gfc_implicit_pure (NULL
))
3009 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3012 /* Functions without the RECURSIVE attribution are not allowed to
3013 * call themselves. */
3014 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3017 esym
= expr
->value
.function
.esym
;
3019 if (is_illegal_recursion (esym
, gfc_current_ns
))
3021 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3022 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3023 " function '%s' is not RECURSIVE",
3024 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3026 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3027 " is not RECURSIVE", esym
->name
, &expr
->where
);
3033 /* Character lengths of use associated functions may contains references to
3034 symbols not referenced from the current program unit otherwise. Make sure
3035 those symbols are marked as referenced. */
3037 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3038 && expr
->value
.function
.esym
->attr
.use_assoc
)
3040 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3043 /* Make sure that the expression has a typespec that works. */
3044 if (expr
->ts
.type
== BT_UNKNOWN
)
3046 if (expr
->symtree
->n
.sym
->result
3047 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3048 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3049 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3056 /************* Subroutine resolution *************/
3059 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3065 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3066 sym
->name
, &c
->loc
);
3067 else if (gfc_do_concurrent_flag
)
3068 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3069 "PURE", sym
->name
, &c
->loc
);
3070 else if (gfc_pure (NULL
))
3071 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3074 if (gfc_implicit_pure (NULL
))
3075 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3080 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3084 if (sym
->attr
.generic
)
3086 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3089 c
->resolved_sym
= s
;
3090 pure_subroutine (c
, s
);
3094 /* TODO: Need to search for elemental references in generic interface. */
3097 if (sym
->attr
.intrinsic
)
3098 return gfc_intrinsic_sub_interface (c
, 0);
3105 resolve_generic_s (gfc_code
*c
)
3110 sym
= c
->symtree
->n
.sym
;
3114 m
= resolve_generic_s0 (c
, sym
);
3117 else if (m
== MATCH_ERROR
)
3121 if (sym
->ns
->parent
== NULL
)
3123 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3127 if (!generic_sym (sym
))
3131 /* Last ditch attempt. See if the reference is to an intrinsic
3132 that possesses a matching interface. 14.1.2.4 */
3133 sym
= c
->symtree
->n
.sym
;
3135 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3137 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3138 sym
->name
, &c
->loc
);
3142 m
= gfc_intrinsic_sub_interface (c
, 0);
3146 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3147 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3153 /* Resolve a subroutine call known to be specific. */
3156 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3160 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3162 if (sym
->attr
.dummy
)
3164 sym
->attr
.proc
= PROC_DUMMY
;
3168 sym
->attr
.proc
= PROC_EXTERNAL
;
3172 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3175 if (sym
->attr
.intrinsic
)
3177 m
= gfc_intrinsic_sub_interface (c
, 1);
3181 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3182 "with an intrinsic", sym
->name
, &c
->loc
);
3190 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3192 c
->resolved_sym
= sym
;
3193 pure_subroutine (c
, sym
);
3200 resolve_specific_s (gfc_code
*c
)
3205 sym
= c
->symtree
->n
.sym
;
3209 m
= resolve_specific_s0 (c
, sym
);
3212 if (m
== MATCH_ERROR
)
3215 if (sym
->ns
->parent
== NULL
)
3218 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3224 sym
= c
->symtree
->n
.sym
;
3225 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3226 sym
->name
, &c
->loc
);
3232 /* Resolve a subroutine call not known to be generic nor specific. */
3235 resolve_unknown_s (gfc_code
*c
)
3239 sym
= c
->symtree
->n
.sym
;
3241 if (sym
->attr
.dummy
)
3243 sym
->attr
.proc
= PROC_DUMMY
;
3247 /* See if we have an intrinsic function reference. */
3249 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3251 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3256 /* The reference is to an external name. */
3259 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3261 c
->resolved_sym
= sym
;
3263 pure_subroutine (c
, sym
);
3269 /* Resolve a subroutine call. Although it was tempting to use the same code
3270 for functions, subroutines and functions are stored differently and this
3271 makes things awkward. */
3274 resolve_call (gfc_code
*c
)
3277 procedure_type ptype
= PROC_INTRINSIC
;
3278 gfc_symbol
*csym
, *sym
;
3279 bool no_formal_args
;
3281 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3283 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3285 gfc_error ("'%s' at %L has a type, which is not consistent with "
3286 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3290 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3293 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3294 sym
= st
? st
->n
.sym
: NULL
;
3295 if (sym
&& csym
!= sym
3296 && sym
->ns
== gfc_current_ns
3297 && sym
->attr
.flavor
== FL_PROCEDURE
3298 && sym
->attr
.contained
)
3301 if (csym
->attr
.generic
)
3302 c
->symtree
->n
.sym
= sym
;
3305 csym
= c
->symtree
->n
.sym
;
3309 /* If this ia a deferred TBP, c->expr1 will be set. */
3310 if (!c
->expr1
&& csym
)
3312 if (csym
->attr
.abstract
)
3314 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3315 csym
->name
, &c
->loc
);
3319 /* Subroutines without the RECURSIVE attribution are not allowed to
3321 if (is_illegal_recursion (csym
, gfc_current_ns
))
3323 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3324 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3325 "as subroutine '%s' is not RECURSIVE",
3326 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3328 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3329 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3335 /* Switch off assumed size checking and do this again for certain kinds
3336 of procedure, once the procedure itself is resolved. */
3337 need_full_assumed_size
++;
3340 ptype
= csym
->attr
.proc
;
3342 no_formal_args
= csym
&& is_external_proc (csym
)
3343 && gfc_sym_get_dummy_args (csym
) == NULL
;
3344 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3347 /* Resume assumed_size checking. */
3348 need_full_assumed_size
--;
3350 /* If external, check for usage. */
3351 if (csym
&& is_external_proc (csym
))
3352 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3355 if (c
->resolved_sym
== NULL
)
3357 c
->resolved_isym
= NULL
;
3358 switch (procedure_kind (csym
))
3361 t
= resolve_generic_s (c
);
3364 case PTYPE_SPECIFIC
:
3365 t
= resolve_specific_s (c
);
3369 t
= resolve_unknown_s (c
);
3373 gfc_internal_error ("resolve_subroutine(): bad function type");
3377 /* Some checks of elemental subroutine actual arguments. */
3378 if (!resolve_elemental_actual (NULL
, c
))
3385 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3386 op1->shape and op2->shape are non-NULL return true if their shapes
3387 match. If both op1->shape and op2->shape are non-NULL return false
3388 if their shapes do not match. If either op1->shape or op2->shape is
3389 NULL, return true. */
3392 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3399 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3401 for (i
= 0; i
< op1
->rank
; i
++)
3403 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3405 gfc_error ("Shapes for operands at %L and %L are not conformable",
3406 &op1
->where
, &op2
->where
);
3417 /* Resolve an operator expression node. This can involve replacing the
3418 operation with a user defined function call. */
3421 resolve_operator (gfc_expr
*e
)
3423 gfc_expr
*op1
, *op2
;
3425 bool dual_locus_error
;
3428 /* Resolve all subnodes-- give them types. */
3430 switch (e
->value
.op
.op
)
3433 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3436 /* Fall through... */
3439 case INTRINSIC_UPLUS
:
3440 case INTRINSIC_UMINUS
:
3441 case INTRINSIC_PARENTHESES
:
3442 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3447 /* Typecheck the new node. */
3449 op1
= e
->value
.op
.op1
;
3450 op2
= e
->value
.op
.op2
;
3451 dual_locus_error
= false;
3453 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3454 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3456 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3460 switch (e
->value
.op
.op
)
3462 case INTRINSIC_UPLUS
:
3463 case INTRINSIC_UMINUS
:
3464 if (op1
->ts
.type
== BT_INTEGER
3465 || op1
->ts
.type
== BT_REAL
3466 || op1
->ts
.type
== BT_COMPLEX
)
3472 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3473 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3476 case INTRINSIC_PLUS
:
3477 case INTRINSIC_MINUS
:
3478 case INTRINSIC_TIMES
:
3479 case INTRINSIC_DIVIDE
:
3480 case INTRINSIC_POWER
:
3481 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3483 gfc_type_convert_binary (e
, 1);
3488 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3489 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3490 gfc_typename (&op2
->ts
));
3493 case INTRINSIC_CONCAT
:
3494 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3495 && op1
->ts
.kind
== op2
->ts
.kind
)
3497 e
->ts
.type
= BT_CHARACTER
;
3498 e
->ts
.kind
= op1
->ts
.kind
;
3503 _("Operands of string concatenation operator at %%L are %s/%s"),
3504 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3510 case INTRINSIC_NEQV
:
3511 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3513 e
->ts
.type
= BT_LOGICAL
;
3514 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3515 if (op1
->ts
.kind
< e
->ts
.kind
)
3516 gfc_convert_type (op1
, &e
->ts
, 2);
3517 else if (op2
->ts
.kind
< e
->ts
.kind
)
3518 gfc_convert_type (op2
, &e
->ts
, 2);
3522 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3523 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3524 gfc_typename (&op2
->ts
));
3529 if (op1
->ts
.type
== BT_LOGICAL
)
3531 e
->ts
.type
= BT_LOGICAL
;
3532 e
->ts
.kind
= op1
->ts
.kind
;
3536 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3537 gfc_typename (&op1
->ts
));
3541 case INTRINSIC_GT_OS
:
3543 case INTRINSIC_GE_OS
:
3545 case INTRINSIC_LT_OS
:
3547 case INTRINSIC_LE_OS
:
3548 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3550 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3554 /* Fall through... */
3557 case INTRINSIC_EQ_OS
:
3559 case INTRINSIC_NE_OS
:
3560 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3561 && op1
->ts
.kind
== op2
->ts
.kind
)
3563 e
->ts
.type
= BT_LOGICAL
;
3564 e
->ts
.kind
= gfc_default_logical_kind
;
3568 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3570 gfc_type_convert_binary (e
, 1);
3572 e
->ts
.type
= BT_LOGICAL
;
3573 e
->ts
.kind
= gfc_default_logical_kind
;
3575 if (gfc_option
.warn_compare_reals
)
3577 gfc_intrinsic_op op
= e
->value
.op
.op
;
3579 /* Type conversion has made sure that the types of op1 and op2
3580 agree, so it is only necessary to check the first one. */
3581 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3582 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3583 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3587 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3588 msg
= "Equality comparison for %s at %L";
3590 msg
= "Inequality comparison for %s at %L";
3592 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3599 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3601 _("Logicals at %%L must be compared with %s instead of %s"),
3602 (e
->value
.op
.op
== INTRINSIC_EQ
3603 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3604 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3607 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3608 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3609 gfc_typename (&op2
->ts
));
3613 case INTRINSIC_USER
:
3614 if (e
->value
.op
.uop
->op
== NULL
)
3615 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3616 else if (op2
== NULL
)
3617 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3618 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3621 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3622 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3623 gfc_typename (&op2
->ts
));
3624 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3629 case INTRINSIC_PARENTHESES
:
3631 if (e
->ts
.type
== BT_CHARACTER
)
3632 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3636 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3639 /* Deal with arrayness of an operand through an operator. */
3643 switch (e
->value
.op
.op
)
3645 case INTRINSIC_PLUS
:
3646 case INTRINSIC_MINUS
:
3647 case INTRINSIC_TIMES
:
3648 case INTRINSIC_DIVIDE
:
3649 case INTRINSIC_POWER
:
3650 case INTRINSIC_CONCAT
:
3654 case INTRINSIC_NEQV
:
3656 case INTRINSIC_EQ_OS
:
3658 case INTRINSIC_NE_OS
:
3660 case INTRINSIC_GT_OS
:
3662 case INTRINSIC_GE_OS
:
3664 case INTRINSIC_LT_OS
:
3666 case INTRINSIC_LE_OS
:
3668 if (op1
->rank
== 0 && op2
->rank
== 0)
3671 if (op1
->rank
== 0 && op2
->rank
!= 0)
3673 e
->rank
= op2
->rank
;
3675 if (e
->shape
== NULL
)
3676 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3679 if (op1
->rank
!= 0 && op2
->rank
== 0)
3681 e
->rank
= op1
->rank
;
3683 if (e
->shape
== NULL
)
3684 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3687 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3689 if (op1
->rank
== op2
->rank
)
3691 e
->rank
= op1
->rank
;
3692 if (e
->shape
== NULL
)
3694 t
= compare_shapes (op1
, op2
);
3698 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3703 /* Allow higher level expressions to work. */
3706 /* Try user-defined operators, and otherwise throw an error. */
3707 dual_locus_error
= true;
3709 _("Inconsistent ranks for operator at %%L and %%L"));
3716 case INTRINSIC_PARENTHESES
:
3718 case INTRINSIC_UPLUS
:
3719 case INTRINSIC_UMINUS
:
3720 /* Simply copy arrayness attribute */
3721 e
->rank
= op1
->rank
;
3723 if (e
->shape
== NULL
)
3724 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3732 /* Attempt to simplify the expression. */
3735 t
= gfc_simplify_expr (e
, 0);
3736 /* Some calls do not succeed in simplification and return false
3737 even though there is no error; e.g. variable references to
3738 PARAMETER arrays. */
3739 if (!gfc_is_constant_expr (e
))
3747 match m
= gfc_extend_expr (e
);
3750 if (m
== MATCH_ERROR
)
3754 if (dual_locus_error
)
3755 gfc_error (msg
, &op1
->where
, &op2
->where
);
3757 gfc_error (msg
, &e
->where
);
3763 /************** Array resolution subroutines **************/
3766 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3769 /* Compare two integer expressions. */
3772 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3776 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3777 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3780 /* If either of the types isn't INTEGER, we must have
3781 raised an error earlier. */
3783 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3786 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3796 /* Compare an integer expression with an integer. */
3799 compare_bound_int (gfc_expr
*a
, int b
)
3803 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3806 if (a
->ts
.type
!= BT_INTEGER
)
3807 gfc_internal_error ("compare_bound_int(): Bad expression");
3809 i
= mpz_cmp_si (a
->value
.integer
, b
);
3819 /* Compare an integer expression with a mpz_t. */
3822 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3826 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3829 if (a
->ts
.type
!= BT_INTEGER
)
3830 gfc_internal_error ("compare_bound_int(): Bad expression");
3832 i
= mpz_cmp (a
->value
.integer
, b
);
3842 /* Compute the last value of a sequence given by a triplet.
3843 Return 0 if it wasn't able to compute the last value, or if the
3844 sequence if empty, and 1 otherwise. */
3847 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3848 gfc_expr
*stride
, mpz_t last
)
3852 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3853 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3854 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3857 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3858 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3861 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3863 if (compare_bound (start
, end
) == CMP_GT
)
3865 mpz_set (last
, end
->value
.integer
);
3869 if (compare_bound_int (stride
, 0) == CMP_GT
)
3871 /* Stride is positive */
3872 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3877 /* Stride is negative */
3878 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3883 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3884 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3885 mpz_sub (last
, end
->value
.integer
, rem
);
3892 /* Compare a single dimension of an array reference to the array
3896 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3900 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3902 gcc_assert (ar
->stride
[i
] == NULL
);
3903 /* This implies [*] as [*:] and [*:3] are not possible. */
3904 if (ar
->start
[i
] == NULL
)
3906 gcc_assert (ar
->end
[i
] == NULL
);
3911 /* Given start, end and stride values, calculate the minimum and
3912 maximum referenced indexes. */
3914 switch (ar
->dimen_type
[i
])
3917 case DIMEN_THIS_IMAGE
:
3922 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3925 gfc_warning ("Array reference at %L is out of bounds "
3926 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3927 mpz_get_si (ar
->start
[i
]->value
.integer
),
3928 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3930 gfc_warning ("Array reference at %L is out of bounds "
3931 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3932 mpz_get_si (ar
->start
[i
]->value
.integer
),
3933 mpz_get_si (as
->lower
[i
]->value
.integer
),
3937 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3940 gfc_warning ("Array reference at %L is out of bounds "
3941 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3942 mpz_get_si (ar
->start
[i
]->value
.integer
),
3943 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3945 gfc_warning ("Array reference at %L is out of bounds "
3946 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3947 mpz_get_si (ar
->start
[i
]->value
.integer
),
3948 mpz_get_si (as
->upper
[i
]->value
.integer
),
3957 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3958 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3960 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3962 /* Check for zero stride, which is not allowed. */
3963 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3965 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3969 /* if start == len || (stride > 0 && start < len)
3970 || (stride < 0 && start > len),
3971 then the array section contains at least one element. In this
3972 case, there is an out-of-bounds access if
3973 (start < lower || start > upper). */
3974 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3975 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3976 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3977 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3978 && comp_start_end
== CMP_GT
))
3980 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3982 gfc_warning ("Lower array reference at %L is out of bounds "
3983 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3984 mpz_get_si (AR_START
->value
.integer
),
3985 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3988 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3990 gfc_warning ("Lower array reference at %L is out of bounds "
3991 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3992 mpz_get_si (AR_START
->value
.integer
),
3993 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3998 /* If we can compute the highest index of the array section,
3999 then it also has to be between lower and upper. */
4000 mpz_init (last_value
);
4001 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4004 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4006 gfc_warning ("Upper array reference at %L is out of bounds "
4007 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4008 mpz_get_si (last_value
),
4009 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4010 mpz_clear (last_value
);
4013 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4015 gfc_warning ("Upper array reference at %L is out of bounds "
4016 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4017 mpz_get_si (last_value
),
4018 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4019 mpz_clear (last_value
);
4023 mpz_clear (last_value
);
4031 gfc_internal_error ("check_dimension(): Bad array reference");
4038 /* Compare an array reference with an array specification. */
4041 compare_spec_to_ref (gfc_array_ref
*ar
)
4048 /* TODO: Full array sections are only allowed as actual parameters. */
4049 if (as
->type
== AS_ASSUMED_SIZE
4050 && (/*ar->type == AR_FULL
4051 ||*/ (ar
->type
== AR_SECTION
4052 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4054 gfc_error ("Rightmost upper bound of assumed size array section "
4055 "not specified at %L", &ar
->where
);
4059 if (ar
->type
== AR_FULL
)
4062 if (as
->rank
!= ar
->dimen
)
4064 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4065 &ar
->where
, ar
->dimen
, as
->rank
);
4069 /* ar->codimen == 0 is a local array. */
4070 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4072 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4073 &ar
->where
, ar
->codimen
, as
->corank
);
4077 for (i
= 0; i
< as
->rank
; i
++)
4078 if (!check_dimension (i
, ar
, as
))
4081 /* Local access has no coarray spec. */
4082 if (ar
->codimen
!= 0)
4083 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4085 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4086 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4088 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4089 i
+ 1 - as
->rank
, &ar
->where
);
4092 if (!check_dimension (i
, ar
, as
))
4100 /* Resolve one part of an array index. */
4103 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4104 int force_index_integer_kind
)
4111 if (!gfc_resolve_expr (index
))
4114 if (check_scalar
&& index
->rank
!= 0)
4116 gfc_error ("Array index at %L must be scalar", &index
->where
);
4120 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4122 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4123 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4127 if (index
->ts
.type
== BT_REAL
)
4128 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4132 if ((index
->ts
.kind
!= gfc_index_integer_kind
4133 && force_index_integer_kind
)
4134 || index
->ts
.type
!= BT_INTEGER
)
4137 ts
.type
= BT_INTEGER
;
4138 ts
.kind
= gfc_index_integer_kind
;
4140 gfc_convert_type_warn (index
, &ts
, 2, 0);
4146 /* Resolve one part of an array index. */
4149 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4151 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4154 /* Resolve a dim argument to an intrinsic function. */
4157 gfc_resolve_dim_arg (gfc_expr
*dim
)
4162 if (!gfc_resolve_expr (dim
))
4167 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4172 if (dim
->ts
.type
!= BT_INTEGER
)
4174 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4178 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4183 ts
.type
= BT_INTEGER
;
4184 ts
.kind
= gfc_index_integer_kind
;
4186 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4192 /* Given an expression that contains array references, update those array
4193 references to point to the right array specifications. While this is
4194 filled in during matching, this information is difficult to save and load
4195 in a module, so we take care of it here.
4197 The idea here is that the original array reference comes from the
4198 base symbol. We traverse the list of reference structures, setting
4199 the stored reference to references. Component references can
4200 provide an additional array specification. */
4203 find_array_spec (gfc_expr
*e
)
4209 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4210 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4212 as
= e
->symtree
->n
.sym
->as
;
4214 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4219 gfc_internal_error ("find_array_spec(): Missing spec");
4226 c
= ref
->u
.c
.component
;
4227 if (c
->attr
.dimension
)
4230 gfc_internal_error ("find_array_spec(): unused as(1)");
4241 gfc_internal_error ("find_array_spec(): unused as(2)");
4245 /* Resolve an array reference. */
4248 resolve_array_ref (gfc_array_ref
*ar
)
4250 int i
, check_scalar
;
4253 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4255 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4257 /* Do not force gfc_index_integer_kind for the start. We can
4258 do fine with any integer kind. This avoids temporary arrays
4259 created for indexing with a vector. */
4260 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4262 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4264 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4269 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4273 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4277 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4278 if (e
->expr_type
== EXPR_VARIABLE
4279 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4280 ar
->start
[i
] = gfc_get_parentheses (e
);
4284 gfc_error ("Array index at %L is an array of rank %d",
4285 &ar
->c_where
[i
], e
->rank
);
4289 /* Fill in the upper bound, which may be lower than the
4290 specified one for something like a(2:10:5), which is
4291 identical to a(2:7:5). Only relevant for strides not equal
4292 to one. Don't try a division by zero. */
4293 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4294 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4295 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4296 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4300 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4302 if (ar
->end
[i
] == NULL
)
4305 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4307 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4309 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4310 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4312 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4323 if (ar
->type
== AR_FULL
)
4325 if (ar
->as
->rank
== 0)
4326 ar
->type
= AR_ELEMENT
;
4328 /* Make sure array is the same as array(:,:), this way
4329 we don't need to special case all the time. */
4330 ar
->dimen
= ar
->as
->rank
;
4331 for (i
= 0; i
< ar
->dimen
; i
++)
4333 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4335 gcc_assert (ar
->start
[i
] == NULL
);
4336 gcc_assert (ar
->end
[i
] == NULL
);
4337 gcc_assert (ar
->stride
[i
] == NULL
);
4341 /* If the reference type is unknown, figure out what kind it is. */
4343 if (ar
->type
== AR_UNKNOWN
)
4345 ar
->type
= AR_ELEMENT
;
4346 for (i
= 0; i
< ar
->dimen
; i
++)
4347 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4348 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4350 ar
->type
= AR_SECTION
;
4355 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4358 if (ar
->as
->corank
&& ar
->codimen
== 0)
4361 ar
->codimen
= ar
->as
->corank
;
4362 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4363 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4371 resolve_substring (gfc_ref
*ref
)
4373 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4375 if (ref
->u
.ss
.start
!= NULL
)
4377 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4380 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4382 gfc_error ("Substring start index at %L must be of type INTEGER",
4383 &ref
->u
.ss
.start
->where
);
4387 if (ref
->u
.ss
.start
->rank
!= 0)
4389 gfc_error ("Substring start index at %L must be scalar",
4390 &ref
->u
.ss
.start
->where
);
4394 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4395 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4396 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4398 gfc_error ("Substring start index at %L is less than one",
4399 &ref
->u
.ss
.start
->where
);
4404 if (ref
->u
.ss
.end
!= NULL
)
4406 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4409 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4411 gfc_error ("Substring end index at %L must be of type INTEGER",
4412 &ref
->u
.ss
.end
->where
);
4416 if (ref
->u
.ss
.end
->rank
!= 0)
4418 gfc_error ("Substring end index at %L must be scalar",
4419 &ref
->u
.ss
.end
->where
);
4423 if (ref
->u
.ss
.length
!= NULL
4424 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4425 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4426 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4428 gfc_error ("Substring end index at %L exceeds the string length",
4429 &ref
->u
.ss
.start
->where
);
4433 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4434 gfc_integer_kinds
[k
].huge
) == CMP_GT
4435 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4436 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4438 gfc_error ("Substring end index at %L is too large",
4439 &ref
->u
.ss
.end
->where
);
4448 /* This function supplies missing substring charlens. */
4451 gfc_resolve_substring_charlen (gfc_expr
*e
)
4454 gfc_expr
*start
, *end
;
4456 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4457 if (char_ref
->type
== REF_SUBSTRING
)
4463 gcc_assert (char_ref
->next
== NULL
);
4467 if (e
->ts
.u
.cl
->length
)
4468 gfc_free_expr (e
->ts
.u
.cl
->length
);
4469 else if (e
->expr_type
== EXPR_VARIABLE
4470 && e
->symtree
->n
.sym
->attr
.dummy
)
4474 e
->ts
.type
= BT_CHARACTER
;
4475 e
->ts
.kind
= gfc_default_character_kind
;
4478 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4480 if (char_ref
->u
.ss
.start
)
4481 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4483 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4485 if (char_ref
->u
.ss
.end
)
4486 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4487 else if (e
->expr_type
== EXPR_VARIABLE
)
4488 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4494 gfc_free_expr (start
);
4495 gfc_free_expr (end
);
4499 /* Length = (end - start +1). */
4500 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4501 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4502 gfc_get_int_expr (gfc_default_integer_kind
,
4505 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4506 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4508 /* Make sure that the length is simplified. */
4509 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4510 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4514 /* Resolve subtype references. */
4517 resolve_ref (gfc_expr
*expr
)
4519 int current_part_dimension
, n_components
, seen_part_dimension
;
4522 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4523 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4525 find_array_spec (expr
);
4529 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4533 if (!resolve_array_ref (&ref
->u
.ar
))
4541 if (!resolve_substring (ref
))
4546 /* Check constraints on part references. */
4548 current_part_dimension
= 0;
4549 seen_part_dimension
= 0;
4552 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4557 switch (ref
->u
.ar
.type
)
4560 /* Coarray scalar. */
4561 if (ref
->u
.ar
.as
->rank
== 0)
4563 current_part_dimension
= 0;
4568 current_part_dimension
= 1;
4572 current_part_dimension
= 0;
4576 gfc_internal_error ("resolve_ref(): Bad array reference");
4582 if (current_part_dimension
|| seen_part_dimension
)
4585 if (ref
->u
.c
.component
->attr
.pointer
4586 || ref
->u
.c
.component
->attr
.proc_pointer
4587 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4588 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4590 gfc_error ("Component to the right of a part reference "
4591 "with nonzero rank must not have the POINTER "
4592 "attribute at %L", &expr
->where
);
4595 else if (ref
->u
.c
.component
->attr
.allocatable
4596 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4597 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4600 gfc_error ("Component to the right of a part reference "
4601 "with nonzero rank must not have the ALLOCATABLE "
4602 "attribute at %L", &expr
->where
);
4614 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4615 || ref
->next
== NULL
)
4616 && current_part_dimension
4617 && seen_part_dimension
)
4619 gfc_error ("Two or more part references with nonzero rank must "
4620 "not be specified at %L", &expr
->where
);
4624 if (ref
->type
== REF_COMPONENT
)
4626 if (current_part_dimension
)
4627 seen_part_dimension
= 1;
4629 /* reset to make sure */
4630 current_part_dimension
= 0;
4638 /* Given an expression, determine its shape. This is easier than it sounds.
4639 Leaves the shape array NULL if it is not possible to determine the shape. */
4642 expression_shape (gfc_expr
*e
)
4644 mpz_t array
[GFC_MAX_DIMENSIONS
];
4647 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4650 for (i
= 0; i
< e
->rank
; i
++)
4651 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4654 e
->shape
= gfc_get_shape (e
->rank
);
4656 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4661 for (i
--; i
>= 0; i
--)
4662 mpz_clear (array
[i
]);
4666 /* Given a variable expression node, compute the rank of the expression by
4667 examining the base symbol and any reference structures it may have. */
4670 expression_rank (gfc_expr
*e
)
4675 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4676 could lead to serious confusion... */
4677 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4681 if (e
->expr_type
== EXPR_ARRAY
)
4683 /* Constructors can have a rank different from one via RESHAPE(). */
4685 if (e
->symtree
== NULL
)
4691 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4692 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4698 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4700 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4701 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4702 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4704 if (ref
->type
!= REF_ARRAY
)
4707 if (ref
->u
.ar
.type
== AR_FULL
)
4709 rank
= ref
->u
.ar
.as
->rank
;
4713 if (ref
->u
.ar
.type
== AR_SECTION
)
4715 /* Figure out the rank of the section. */
4717 gfc_internal_error ("expression_rank(): Two array specs");
4719 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4720 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4721 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4731 expression_shape (e
);
4735 /* Resolve a variable expression. */
4738 resolve_variable (gfc_expr
*e
)
4745 if (e
->symtree
== NULL
)
4747 sym
= e
->symtree
->n
.sym
;
4749 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4750 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4751 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4753 if (!actual_arg
|| inquiry_argument
)
4755 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4756 "be used as actual argument", sym
->name
, &e
->where
);
4760 /* TS 29113, 407b. */
4761 else if (e
->ts
.type
== BT_ASSUMED
)
4765 gfc_error ("Assumed-type variable %s at %L may only be used "
4766 "as actual argument", sym
->name
, &e
->where
);
4769 else if (inquiry_argument
&& !first_actual_arg
)
4771 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4772 for all inquiry functions in resolve_function; the reason is
4773 that the function-name resolution happens too late in that
4775 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4776 "an inquiry function shall be the first argument",
4777 sym
->name
, &e
->where
);
4781 /* TS 29113, C535b. */
4782 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4783 && CLASS_DATA (sym
)->as
4784 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4785 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4786 && sym
->as
->type
== AS_ASSUMED_RANK
))
4790 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4791 "actual argument", sym
->name
, &e
->where
);
4794 else if (inquiry_argument
&& !first_actual_arg
)
4796 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4797 for all inquiry functions in resolve_function; the reason is
4798 that the function-name resolution happens too late in that
4800 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4801 "to an inquiry function shall be the first argument",
4802 sym
->name
, &e
->where
);
4807 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4808 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4809 && e
->ref
->next
== NULL
))
4811 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4812 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4815 /* TS 29113, 407b. */
4816 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4817 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4818 && e
->ref
->next
== NULL
))
4820 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4821 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4825 /* TS 29113, C535b. */
4826 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4827 && CLASS_DATA (sym
)->as
4828 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4829 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4830 && sym
->as
->type
== AS_ASSUMED_RANK
))
4832 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4833 && e
->ref
->next
== NULL
))
4835 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4836 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4841 /* If this is an associate-name, it may be parsed with an array reference
4842 in error even though the target is scalar. Fail directly in this case.
4843 TODO Understand why class scalar expressions must be excluded. */
4844 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4846 if (sym
->ts
.type
== BT_CLASS
)
4847 gfc_fix_class_refs (e
);
4848 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4852 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4853 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4855 /* On the other hand, the parser may not have known this is an array;
4856 in this case, we have to add a FULL reference. */
4857 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4859 e
->ref
= gfc_get_ref ();
4860 e
->ref
->type
= REF_ARRAY
;
4861 e
->ref
->u
.ar
.type
= AR_FULL
;
4862 e
->ref
->u
.ar
.dimen
= 0;
4865 if (e
->ref
&& !resolve_ref (e
))
4868 if (sym
->attr
.flavor
== FL_PROCEDURE
4869 && (!sym
->attr
.function
4870 || (sym
->attr
.function
&& sym
->result
4871 && sym
->result
->attr
.proc_pointer
4872 && !sym
->result
->attr
.function
)))
4874 e
->ts
.type
= BT_PROCEDURE
;
4875 goto resolve_procedure
;
4878 if (sym
->ts
.type
!= BT_UNKNOWN
)
4879 gfc_variable_attr (e
, &e
->ts
);
4882 /* Must be a simple variable reference. */
4883 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4888 if (check_assumed_size_reference (sym
, e
))
4891 /* Deal with forward references to entries during resolve_code, to
4892 satisfy, at least partially, 12.5.2.5. */
4893 if (gfc_current_ns
->entries
4894 && current_entry_id
== sym
->entry_id
4897 && cs_base
->current
->op
!= EXEC_ENTRY
)
4899 gfc_entry_list
*entry
;
4900 gfc_formal_arglist
*formal
;
4902 bool seen
, saved_specification_expr
;
4904 /* If the symbol is a dummy... */
4905 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4907 entry
= gfc_current_ns
->entries
;
4910 /* ...test if the symbol is a parameter of previous entries. */
4911 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4912 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4914 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4921 /* If it has not been seen as a dummy, this is an error. */
4924 if (specification_expr
)
4925 gfc_error ("Variable '%s', used in a specification expression"
4926 ", is referenced at %L before the ENTRY statement "
4927 "in which it is a parameter",
4928 sym
->name
, &cs_base
->current
->loc
);
4930 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4931 "statement in which it is a parameter",
4932 sym
->name
, &cs_base
->current
->loc
);
4937 /* Now do the same check on the specification expressions. */
4938 saved_specification_expr
= specification_expr
;
4939 specification_expr
= true;
4940 if (sym
->ts
.type
== BT_CHARACTER
4941 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4945 for (n
= 0; n
< sym
->as
->rank
; n
++)
4947 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4949 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4952 specification_expr
= saved_specification_expr
;
4955 /* Update the symbol's entry level. */
4956 sym
->entry_id
= current_entry_id
+ 1;
4959 /* If a symbol has been host_associated mark it. This is used latter,
4960 to identify if aliasing is possible via host association. */
4961 if (sym
->attr
.flavor
== FL_VARIABLE
4962 && gfc_current_ns
->parent
4963 && (gfc_current_ns
->parent
== sym
->ns
4964 || (gfc_current_ns
->parent
->parent
4965 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
4966 sym
->attr
.host_assoc
= 1;
4969 if (t
&& !resolve_procedure_expression (e
))
4972 /* F2008, C617 and C1229. */
4973 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
4974 && gfc_is_coindexed (e
))
4976 gfc_ref
*ref
, *ref2
= NULL
;
4978 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4980 if (ref
->type
== REF_COMPONENT
)
4982 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4986 for ( ; ref
; ref
= ref
->next
)
4987 if (ref
->type
== REF_COMPONENT
)
4990 /* Expression itself is not coindexed object. */
4991 if (ref
&& e
->ts
.type
== BT_CLASS
)
4993 gfc_error ("Polymorphic subobject of coindexed object at %L",
4998 /* Expression itself is coindexed object. */
5002 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5003 for ( ; c
; c
= c
->next
)
5004 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5006 gfc_error ("Coindexed object with polymorphic allocatable "
5007 "subcomponent at %L", &e
->where
);
5018 /* Checks to see that the correct symbol has been host associated.
5019 The only situation where this arises is that in which a twice
5020 contained function is parsed after the host association is made.
5021 Therefore, on detecting this, change the symbol in the expression
5022 and convert the array reference into an actual arglist if the old
5023 symbol is a variable. */
5025 check_host_association (gfc_expr
*e
)
5027 gfc_symbol
*sym
, *old_sym
;
5031 gfc_actual_arglist
*arg
, *tail
= NULL
;
5032 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5034 /* If the expression is the result of substitution in
5035 interface.c(gfc_extend_expr) because there is no way in
5036 which the host association can be wrong. */
5037 if (e
->symtree
== NULL
5038 || e
->symtree
->n
.sym
== NULL
5039 || e
->user_operator
)
5042 old_sym
= e
->symtree
->n
.sym
;
5044 if (gfc_current_ns
->parent
5045 && old_sym
->ns
!= gfc_current_ns
)
5047 /* Use the 'USE' name so that renamed module symbols are
5048 correctly handled. */
5049 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5051 if (sym
&& old_sym
!= sym
5052 && sym
->ts
.type
== old_sym
->ts
.type
5053 && sym
->attr
.flavor
== FL_PROCEDURE
5054 && sym
->attr
.contained
)
5056 /* Clear the shape, since it might not be valid. */
5057 gfc_free_shape (&e
->shape
, e
->rank
);
5059 /* Give the expression the right symtree! */
5060 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5061 gcc_assert (st
!= NULL
);
5063 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5064 || e
->expr_type
== EXPR_FUNCTION
)
5066 /* Original was function so point to the new symbol, since
5067 the actual argument list is already attached to the
5069 e
->value
.function
.esym
= NULL
;
5074 /* Original was variable so convert array references into
5075 an actual arglist. This does not need any checking now
5076 since resolve_function will take care of it. */
5077 e
->value
.function
.actual
= NULL
;
5078 e
->expr_type
= EXPR_FUNCTION
;
5081 /* Ambiguity will not arise if the array reference is not
5082 the last reference. */
5083 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5084 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5087 gcc_assert (ref
->type
== REF_ARRAY
);
5089 /* Grab the start expressions from the array ref and
5090 copy them into actual arguments. */
5091 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5093 arg
= gfc_get_actual_arglist ();
5094 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5095 if (e
->value
.function
.actual
== NULL
)
5096 tail
= e
->value
.function
.actual
= arg
;
5104 /* Dump the reference list and set the rank. */
5105 gfc_free_ref_list (e
->ref
);
5107 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5110 gfc_resolve_expr (e
);
5114 /* This might have changed! */
5115 return e
->expr_type
== EXPR_FUNCTION
;
5120 gfc_resolve_character_operator (gfc_expr
*e
)
5122 gfc_expr
*op1
= e
->value
.op
.op1
;
5123 gfc_expr
*op2
= e
->value
.op
.op2
;
5124 gfc_expr
*e1
= NULL
;
5125 gfc_expr
*e2
= NULL
;
5127 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5129 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5130 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5131 else if (op1
->expr_type
== EXPR_CONSTANT
)
5132 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5133 op1
->value
.character
.length
);
5135 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5136 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5137 else if (op2
->expr_type
== EXPR_CONSTANT
)
5138 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5139 op2
->value
.character
.length
);
5141 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5151 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5152 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5153 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5154 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5155 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5161 /* Ensure that an character expression has a charlen and, if possible, a
5162 length expression. */
5165 fixup_charlen (gfc_expr
*e
)
5167 /* The cases fall through so that changes in expression type and the need
5168 for multiple fixes are picked up. In all circumstances, a charlen should
5169 be available for the middle end to hang a backend_decl on. */
5170 switch (e
->expr_type
)
5173 gfc_resolve_character_operator (e
);
5176 if (e
->expr_type
== EXPR_ARRAY
)
5177 gfc_resolve_character_array_constructor (e
);
5179 case EXPR_SUBSTRING
:
5180 if (!e
->ts
.u
.cl
&& e
->ref
)
5181 gfc_resolve_substring_charlen (e
);
5185 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5192 /* Update an actual argument to include the passed-object for type-bound
5193 procedures at the right position. */
5195 static gfc_actual_arglist
*
5196 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5199 gcc_assert (argpos
> 0);
5203 gfc_actual_arglist
* result
;
5205 result
= gfc_get_actual_arglist ();
5209 result
->name
= name
;
5215 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5217 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5222 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5225 extract_compcall_passed_object (gfc_expr
* e
)
5229 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5231 if (e
->value
.compcall
.base_object
)
5232 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5235 po
= gfc_get_expr ();
5236 po
->expr_type
= EXPR_VARIABLE
;
5237 po
->symtree
= e
->symtree
;
5238 po
->ref
= gfc_copy_ref (e
->ref
);
5239 po
->where
= e
->where
;
5242 if (!gfc_resolve_expr (po
))
5249 /* Update the arglist of an EXPR_COMPCALL expression to include the
5253 update_compcall_arglist (gfc_expr
* e
)
5256 gfc_typebound_proc
* tbp
;
5258 tbp
= e
->value
.compcall
.tbp
;
5263 po
= extract_compcall_passed_object (e
);
5267 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5273 gcc_assert (tbp
->pass_arg_num
> 0);
5274 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5282 /* Extract the passed object from a PPC call (a copy of it). */
5285 extract_ppc_passed_object (gfc_expr
*e
)
5290 po
= gfc_get_expr ();
5291 po
->expr_type
= EXPR_VARIABLE
;
5292 po
->symtree
= e
->symtree
;
5293 po
->ref
= gfc_copy_ref (e
->ref
);
5294 po
->where
= e
->where
;
5296 /* Remove PPC reference. */
5298 while ((*ref
)->next
)
5299 ref
= &(*ref
)->next
;
5300 gfc_free_ref_list (*ref
);
5303 if (!gfc_resolve_expr (po
))
5310 /* Update the actual arglist of a procedure pointer component to include the
5314 update_ppc_arglist (gfc_expr
* e
)
5318 gfc_typebound_proc
* tb
;
5320 ppc
= gfc_get_proc_ptr_comp (e
);
5328 else if (tb
->nopass
)
5331 po
= extract_ppc_passed_object (e
);
5338 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5343 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5345 gfc_error ("Base object for procedure-pointer component call at %L is of"
5346 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5350 gcc_assert (tb
->pass_arg_num
> 0);
5351 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5359 /* Check that the object a TBP is called on is valid, i.e. it must not be
5360 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5363 check_typebound_baseobject (gfc_expr
* e
)
5366 bool return_value
= false;
5368 base
= extract_compcall_passed_object (e
);
5372 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5374 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5378 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5380 gfc_error ("Base object for type-bound procedure call at %L is of"
5381 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5385 /* F08:C1230. If the procedure called is NOPASS,
5386 the base object must be scalar. */
5387 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5389 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5390 " be scalar", &e
->where
);
5394 return_value
= true;
5397 gfc_free_expr (base
);
5398 return return_value
;
5402 /* Resolve a call to a type-bound procedure, either function or subroutine,
5403 statically from the data in an EXPR_COMPCALL expression. The adapted
5404 arglist and the target-procedure symtree are returned. */
5407 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5408 gfc_actual_arglist
** actual
)
5410 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5411 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5413 /* Update the actual arglist for PASS. */
5414 if (!update_compcall_arglist (e
))
5417 *actual
= e
->value
.compcall
.actual
;
5418 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5420 gfc_free_ref_list (e
->ref
);
5422 e
->value
.compcall
.actual
= NULL
;
5424 /* If we find a deferred typebound procedure, check for derived types
5425 that an overriding typebound procedure has not been missed. */
5426 if (e
->value
.compcall
.name
5427 && !e
->value
.compcall
.tbp
->non_overridable
5428 && e
->value
.compcall
.base_object
5429 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5432 gfc_symbol
*derived
;
5434 /* Use the derived type of the base_object. */
5435 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5438 /* If necessary, go through the inheritance chain. */
5439 while (!st
&& derived
)
5441 /* Look for the typebound procedure 'name'. */
5442 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5443 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5444 e
->value
.compcall
.name
);
5446 derived
= gfc_get_derived_super_type (derived
);
5449 /* Now find the specific name in the derived type namespace. */
5450 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5451 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5452 derived
->ns
, 1, &st
);
5460 /* Get the ultimate declared type from an expression. In addition,
5461 return the last class/derived type reference and the copy of the
5462 reference list. If check_types is set true, derived types are
5463 identified as well as class references. */
5465 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5466 gfc_expr
*e
, bool check_types
)
5468 gfc_symbol
*declared
;
5475 *new_ref
= gfc_copy_ref (e
->ref
);
5477 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5479 if (ref
->type
!= REF_COMPONENT
)
5482 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5483 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5484 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5486 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5492 if (declared
== NULL
)
5493 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5499 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5500 which of the specific bindings (if any) matches the arglist and transform
5501 the expression into a call of that binding. */
5504 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5506 gfc_typebound_proc
* genproc
;
5507 const char* genname
;
5509 gfc_symbol
*derived
;
5511 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5512 genname
= e
->value
.compcall
.name
;
5513 genproc
= e
->value
.compcall
.tbp
;
5515 if (!genproc
->is_generic
)
5518 /* Try the bindings on this type and in the inheritance hierarchy. */
5519 for (; genproc
; genproc
= genproc
->overridden
)
5523 gcc_assert (genproc
->is_generic
);
5524 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5527 gfc_actual_arglist
* args
;
5530 gcc_assert (g
->specific
);
5532 if (g
->specific
->error
)
5535 target
= g
->specific
->u
.specific
->n
.sym
;
5537 /* Get the right arglist by handling PASS/NOPASS. */
5538 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5539 if (!g
->specific
->nopass
)
5542 po
= extract_compcall_passed_object (e
);
5545 gfc_free_actual_arglist (args
);
5549 gcc_assert (g
->specific
->pass_arg_num
> 0);
5550 gcc_assert (!g
->specific
->error
);
5551 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5552 g
->specific
->pass_arg
);
5554 resolve_actual_arglist (args
, target
->attr
.proc
,
5555 is_external_proc (target
)
5556 && gfc_sym_get_dummy_args (target
) == NULL
);
5558 /* Check if this arglist matches the formal. */
5559 matches
= gfc_arglist_matches_symbol (&args
, target
);
5561 /* Clean up and break out of the loop if we've found it. */
5562 gfc_free_actual_arglist (args
);
5565 e
->value
.compcall
.tbp
= g
->specific
;
5566 genname
= g
->specific_st
->name
;
5567 /* Pass along the name for CLASS methods, where the vtab
5568 procedure pointer component has to be referenced. */
5576 /* Nothing matching found! */
5577 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5578 " '%s' at %L", genname
, &e
->where
);
5582 /* Make sure that we have the right specific instance for the name. */
5583 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5585 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5587 e
->value
.compcall
.tbp
= st
->n
.tb
;
5593 /* Resolve a call to a type-bound subroutine. */
5596 resolve_typebound_call (gfc_code
* c
, const char **name
)
5598 gfc_actual_arglist
* newactual
;
5599 gfc_symtree
* target
;
5601 /* Check that's really a SUBROUTINE. */
5602 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5604 gfc_error ("'%s' at %L should be a SUBROUTINE",
5605 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5609 if (!check_typebound_baseobject (c
->expr1
))
5612 /* Pass along the name for CLASS methods, where the vtab
5613 procedure pointer component has to be referenced. */
5615 *name
= c
->expr1
->value
.compcall
.name
;
5617 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5620 /* Transform into an ordinary EXEC_CALL for now. */
5622 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5625 c
->ext
.actual
= newactual
;
5626 c
->symtree
= target
;
5627 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5629 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5631 gfc_free_expr (c
->expr1
);
5632 c
->expr1
= gfc_get_expr ();
5633 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5634 c
->expr1
->symtree
= target
;
5635 c
->expr1
->where
= c
->loc
;
5637 return resolve_call (c
);
5641 /* Resolve a component-call expression. */
5643 resolve_compcall (gfc_expr
* e
, const char **name
)
5645 gfc_actual_arglist
* newactual
;
5646 gfc_symtree
* target
;
5648 /* Check that's really a FUNCTION. */
5649 if (!e
->value
.compcall
.tbp
->function
)
5651 gfc_error ("'%s' at %L should be a FUNCTION",
5652 e
->value
.compcall
.name
, &e
->where
);
5656 /* These must not be assign-calls! */
5657 gcc_assert (!e
->value
.compcall
.assign
);
5659 if (!check_typebound_baseobject (e
))
5662 /* Pass along the name for CLASS methods, where the vtab
5663 procedure pointer component has to be referenced. */
5665 *name
= e
->value
.compcall
.name
;
5667 if (!resolve_typebound_generic_call (e
, name
))
5669 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5671 /* Take the rank from the function's symbol. */
5672 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5673 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5675 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5676 arglist to the TBP's binding target. */
5678 if (!resolve_typebound_static (e
, &target
, &newactual
))
5681 e
->value
.function
.actual
= newactual
;
5682 e
->value
.function
.name
= NULL
;
5683 e
->value
.function
.esym
= target
->n
.sym
;
5684 e
->value
.function
.isym
= NULL
;
5685 e
->symtree
= target
;
5686 e
->ts
= target
->n
.sym
->ts
;
5687 e
->expr_type
= EXPR_FUNCTION
;
5689 /* Resolution is not necessary if this is a class subroutine; this
5690 function only has to identify the specific proc. Resolution of
5691 the call will be done next in resolve_typebound_call. */
5692 return gfc_resolve_expr (e
);
5696 static bool resolve_fl_derived (gfc_symbol
*sym
);
5699 /* Resolve a typebound function, or 'method'. First separate all
5700 the non-CLASS references by calling resolve_compcall directly. */
5703 resolve_typebound_function (gfc_expr
* e
)
5705 gfc_symbol
*declared
;
5717 /* Deal with typebound operators for CLASS objects. */
5718 expr
= e
->value
.compcall
.base_object
;
5719 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5720 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5722 /* If the base_object is not a variable, the corresponding actual
5723 argument expression must be stored in e->base_expression so
5724 that the corresponding tree temporary can be used as the base
5725 object in gfc_conv_procedure_call. */
5726 if (expr
->expr_type
!= EXPR_VARIABLE
)
5728 gfc_actual_arglist
*args
;
5730 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5732 if (expr
== args
->expr
)
5737 /* Since the typebound operators are generic, we have to ensure
5738 that any delays in resolution are corrected and that the vtab
5741 declared
= ts
.u
.derived
;
5742 c
= gfc_find_component (declared
, "_vptr", true, true);
5743 if (c
->ts
.u
.derived
== NULL
)
5744 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5746 if (!resolve_compcall (e
, &name
))
5749 /* Use the generic name if it is there. */
5750 name
= name
? name
: e
->value
.function
.esym
->name
;
5751 e
->symtree
= expr
->symtree
;
5752 e
->ref
= gfc_copy_ref (expr
->ref
);
5753 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5755 /* Trim away the extraneous references that emerge from nested
5756 use of interface.c (extend_expr). */
5757 if (class_ref
&& class_ref
->next
)
5759 gfc_free_ref_list (class_ref
->next
);
5760 class_ref
->next
= NULL
;
5762 else if (e
->ref
&& !class_ref
)
5764 gfc_free_ref_list (e
->ref
);
5768 gfc_add_vptr_component (e
);
5769 gfc_add_component_ref (e
, name
);
5770 e
->value
.function
.esym
= NULL
;
5771 if (expr
->expr_type
!= EXPR_VARIABLE
)
5772 e
->base_expr
= expr
;
5777 return resolve_compcall (e
, NULL
);
5779 if (!resolve_ref (e
))
5782 /* Get the CLASS declared type. */
5783 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5785 if (!resolve_fl_derived (declared
))
5788 /* Weed out cases of the ultimate component being a derived type. */
5789 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5790 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5792 gfc_free_ref_list (new_ref
);
5793 return resolve_compcall (e
, NULL
);
5796 c
= gfc_find_component (declared
, "_data", true, true);
5797 declared
= c
->ts
.u
.derived
;
5799 /* Treat the call as if it is a typebound procedure, in order to roll
5800 out the correct name for the specific function. */
5801 if (!resolve_compcall (e
, &name
))
5803 gfc_free_ref_list (new_ref
);
5810 /* Convert the expression to a procedure pointer component call. */
5811 e
->value
.function
.esym
= NULL
;
5817 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5818 gfc_add_vptr_component (e
);
5819 gfc_add_component_ref (e
, name
);
5821 /* Recover the typespec for the expression. This is really only
5822 necessary for generic procedures, where the additional call
5823 to gfc_add_component_ref seems to throw the collection of the
5824 correct typespec. */
5828 gfc_free_ref_list (new_ref
);
5833 /* Resolve a typebound subroutine, or 'method'. First separate all
5834 the non-CLASS references by calling resolve_typebound_call
5838 resolve_typebound_subroutine (gfc_code
*code
)
5840 gfc_symbol
*declared
;
5850 st
= code
->expr1
->symtree
;
5852 /* Deal with typebound operators for CLASS objects. */
5853 expr
= code
->expr1
->value
.compcall
.base_object
;
5854 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5855 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5857 /* If the base_object is not a variable, the corresponding actual
5858 argument expression must be stored in e->base_expression so
5859 that the corresponding tree temporary can be used as the base
5860 object in gfc_conv_procedure_call. */
5861 if (expr
->expr_type
!= EXPR_VARIABLE
)
5863 gfc_actual_arglist
*args
;
5865 args
= code
->expr1
->value
.function
.actual
;
5866 for (; args
; args
= args
->next
)
5867 if (expr
== args
->expr
)
5871 /* Since the typebound operators are generic, we have to ensure
5872 that any delays in resolution are corrected and that the vtab
5874 declared
= expr
->ts
.u
.derived
;
5875 c
= gfc_find_component (declared
, "_vptr", true, true);
5876 if (c
->ts
.u
.derived
== NULL
)
5877 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5879 if (!resolve_typebound_call (code
, &name
))
5882 /* Use the generic name if it is there. */
5883 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5884 code
->expr1
->symtree
= expr
->symtree
;
5885 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5887 /* Trim away the extraneous references that emerge from nested
5888 use of interface.c (extend_expr). */
5889 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5890 if (class_ref
&& class_ref
->next
)
5892 gfc_free_ref_list (class_ref
->next
);
5893 class_ref
->next
= NULL
;
5895 else if (code
->expr1
->ref
&& !class_ref
)
5897 gfc_free_ref_list (code
->expr1
->ref
);
5898 code
->expr1
->ref
= NULL
;
5901 /* Now use the procedure in the vtable. */
5902 gfc_add_vptr_component (code
->expr1
);
5903 gfc_add_component_ref (code
->expr1
, name
);
5904 code
->expr1
->value
.function
.esym
= NULL
;
5905 if (expr
->expr_type
!= EXPR_VARIABLE
)
5906 code
->expr1
->base_expr
= expr
;
5911 return resolve_typebound_call (code
, NULL
);
5913 if (!resolve_ref (code
->expr1
))
5916 /* Get the CLASS declared type. */
5917 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5919 /* Weed out cases of the ultimate component being a derived type. */
5920 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5921 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5923 gfc_free_ref_list (new_ref
);
5924 return resolve_typebound_call (code
, NULL
);
5927 if (!resolve_typebound_call (code
, &name
))
5929 gfc_free_ref_list (new_ref
);
5932 ts
= code
->expr1
->ts
;
5936 /* Convert the expression to a procedure pointer component call. */
5937 code
->expr1
->value
.function
.esym
= NULL
;
5938 code
->expr1
->symtree
= st
;
5941 code
->expr1
->ref
= new_ref
;
5943 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5944 gfc_add_vptr_component (code
->expr1
);
5945 gfc_add_component_ref (code
->expr1
, name
);
5947 /* Recover the typespec for the expression. This is really only
5948 necessary for generic procedures, where the additional call
5949 to gfc_add_component_ref seems to throw the collection of the
5950 correct typespec. */
5951 code
->expr1
->ts
= ts
;
5954 gfc_free_ref_list (new_ref
);
5960 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5963 resolve_ppc_call (gfc_code
* c
)
5965 gfc_component
*comp
;
5967 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
5968 gcc_assert (comp
!= NULL
);
5970 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5971 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5973 if (!comp
->attr
.subroutine
)
5974 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5976 if (!resolve_ref (c
->expr1
))
5979 if (!update_ppc_arglist (c
->expr1
))
5982 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5984 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5985 !(comp
->ts
.interface
5986 && comp
->ts
.interface
->formal
)))
5989 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5995 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5998 resolve_expr_ppc (gfc_expr
* e
)
6000 gfc_component
*comp
;
6002 comp
= gfc_get_proc_ptr_comp (e
);
6003 gcc_assert (comp
!= NULL
);
6005 /* Convert to EXPR_FUNCTION. */
6006 e
->expr_type
= EXPR_FUNCTION
;
6007 e
->value
.function
.isym
= NULL
;
6008 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6010 if (comp
->as
!= NULL
)
6011 e
->rank
= comp
->as
->rank
;
6013 if (!comp
->attr
.function
)
6014 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6016 if (!resolve_ref (e
))
6019 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6020 !(comp
->ts
.interface
6021 && comp
->ts
.interface
->formal
)))
6024 if (!update_ppc_arglist (e
))
6027 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6034 gfc_is_expandable_expr (gfc_expr
*e
)
6036 gfc_constructor
*con
;
6038 if (e
->expr_type
== EXPR_ARRAY
)
6040 /* Traverse the constructor looking for variables that are flavor
6041 parameter. Parameters must be expanded since they are fully used at
6043 con
= gfc_constructor_first (e
->value
.constructor
);
6044 for (; con
; con
= gfc_constructor_next (con
))
6046 if (con
->expr
->expr_type
== EXPR_VARIABLE
6047 && con
->expr
->symtree
6048 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6049 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6051 if (con
->expr
->expr_type
== EXPR_ARRAY
6052 && gfc_is_expandable_expr (con
->expr
))
6060 /* Resolve an expression. That is, make sure that types of operands agree
6061 with their operators, intrinsic operators are converted to function calls
6062 for overloaded types and unresolved function references are resolved. */
6065 gfc_resolve_expr (gfc_expr
*e
)
6068 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6073 /* inquiry_argument only applies to variables. */
6074 inquiry_save
= inquiry_argument
;
6075 actual_arg_save
= actual_arg
;
6076 first_actual_arg_save
= first_actual_arg
;
6078 if (e
->expr_type
!= EXPR_VARIABLE
)
6080 inquiry_argument
= false;
6082 first_actual_arg
= false;
6085 switch (e
->expr_type
)
6088 t
= resolve_operator (e
);
6094 if (check_host_association (e
))
6095 t
= resolve_function (e
);
6098 t
= resolve_variable (e
);
6100 expression_rank (e
);
6103 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6104 && e
->ref
->type
!= REF_SUBSTRING
)
6105 gfc_resolve_substring_charlen (e
);
6110 t
= resolve_typebound_function (e
);
6113 case EXPR_SUBSTRING
:
6114 t
= resolve_ref (e
);
6123 t
= resolve_expr_ppc (e
);
6128 if (!resolve_ref (e
))
6131 t
= gfc_resolve_array_constructor (e
);
6132 /* Also try to expand a constructor. */
6135 expression_rank (e
);
6136 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6137 gfc_expand_constructor (e
, false);
6140 /* This provides the opportunity for the length of constructors with
6141 character valued function elements to propagate the string length
6142 to the expression. */
6143 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6145 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6146 here rather then add a duplicate test for it above. */
6147 gfc_expand_constructor (e
, false);
6148 t
= gfc_resolve_character_array_constructor (e
);
6153 case EXPR_STRUCTURE
:
6154 t
= resolve_ref (e
);
6158 t
= resolve_structure_cons (e
, 0);
6162 t
= gfc_simplify_expr (e
, 0);
6166 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6169 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6172 inquiry_argument
= inquiry_save
;
6173 actual_arg
= actual_arg_save
;
6174 first_actual_arg
= first_actual_arg_save
;
6180 /* Resolve an expression from an iterator. They must be scalar and have
6181 INTEGER or (optionally) REAL type. */
6184 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6185 const char *name_msgid
)
6187 if (!gfc_resolve_expr (expr
))
6190 if (expr
->rank
!= 0)
6192 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6196 if (expr
->ts
.type
!= BT_INTEGER
)
6198 if (expr
->ts
.type
== BT_REAL
)
6201 return gfc_notify_std (GFC_STD_F95_DEL
,
6202 "%s at %L must be integer",
6203 _(name_msgid
), &expr
->where
);
6206 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6213 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6221 /* Resolve the expressions in an iterator structure. If REAL_OK is
6222 false allow only INTEGER type iterators, otherwise allow REAL types.
6223 Set own_scope to true for ac-implied-do and data-implied-do as those
6224 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6227 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6229 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6232 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6233 _("iterator variable")))
6236 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6237 "Start expression in DO loop"))
6240 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6241 "End expression in DO loop"))
6244 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6245 "Step expression in DO loop"))
6248 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6250 if ((iter
->step
->ts
.type
== BT_INTEGER
6251 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6252 || (iter
->step
->ts
.type
== BT_REAL
6253 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6255 gfc_error ("Step expression in DO loop at %L cannot be zero",
6256 &iter
->step
->where
);
6261 /* Convert start, end, and step to the same type as var. */
6262 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6263 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6264 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6266 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6267 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6268 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6270 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6271 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6272 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6274 if (iter
->start
->expr_type
== EXPR_CONSTANT
6275 && iter
->end
->expr_type
== EXPR_CONSTANT
6276 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6279 if (iter
->start
->ts
.type
== BT_INTEGER
)
6281 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6282 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6286 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6287 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6289 if (gfc_option
.warn_zerotrip
&&
6290 ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6291 gfc_warning ("DO loop at %L will be executed zero times"
6292 " (use -Wno-zerotrip to suppress)",
6293 &iter
->step
->where
);
6300 /* Traversal function for find_forall_index. f == 2 signals that
6301 that variable itself is not to be checked - only the references. */
6304 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6306 if (expr
->expr_type
!= EXPR_VARIABLE
)
6309 /* A scalar assignment */
6310 if (!expr
->ref
|| *f
== 1)
6312 if (expr
->symtree
->n
.sym
== sym
)
6324 /* Check whether the FORALL index appears in the expression or not.
6325 Returns true if SYM is found in EXPR. */
6328 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6330 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6337 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6338 to be a scalar INTEGER variable. The subscripts and stride are scalar
6339 INTEGERs, and if stride is a constant it must be nonzero.
6340 Furthermore "A subscript or stride in a forall-triplet-spec shall
6341 not contain a reference to any index-name in the
6342 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6345 resolve_forall_iterators (gfc_forall_iterator
*it
)
6347 gfc_forall_iterator
*iter
, *iter2
;
6349 for (iter
= it
; iter
; iter
= iter
->next
)
6351 if (gfc_resolve_expr (iter
->var
)
6352 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6353 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6356 if (gfc_resolve_expr (iter
->start
)
6357 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6358 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6359 &iter
->start
->where
);
6360 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6361 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6363 if (gfc_resolve_expr (iter
->end
)
6364 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6365 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6367 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6368 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6370 if (gfc_resolve_expr (iter
->stride
))
6372 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6373 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6374 &iter
->stride
->where
, "INTEGER");
6376 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6377 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6378 gfc_error ("FORALL stride expression at %L cannot be zero",
6379 &iter
->stride
->where
);
6381 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6382 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6385 for (iter
= it
; iter
; iter
= iter
->next
)
6386 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6388 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6389 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6390 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6391 gfc_error ("FORALL index '%s' may not appear in triplet "
6392 "specification at %L", iter
->var
->symtree
->name
,
6393 &iter2
->start
->where
);
6398 /* Given a pointer to a symbol that is a derived type, see if it's
6399 inaccessible, i.e. if it's defined in another module and the components are
6400 PRIVATE. The search is recursive if necessary. Returns zero if no
6401 inaccessible components are found, nonzero otherwise. */
6404 derived_inaccessible (gfc_symbol
*sym
)
6408 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6411 for (c
= sym
->components
; c
; c
= c
->next
)
6413 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6421 /* Resolve the argument of a deallocate expression. The expression must be
6422 a pointer or a full array. */
6425 resolve_deallocate_expr (gfc_expr
*e
)
6427 symbol_attribute attr
;
6428 int allocatable
, pointer
;
6434 if (!gfc_resolve_expr (e
))
6437 if (e
->expr_type
!= EXPR_VARIABLE
)
6440 sym
= e
->symtree
->n
.sym
;
6441 unlimited
= UNLIMITED_POLY(sym
);
6443 if (sym
->ts
.type
== BT_CLASS
)
6445 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6446 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6450 allocatable
= sym
->attr
.allocatable
;
6451 pointer
= sym
->attr
.pointer
;
6453 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6458 if (ref
->u
.ar
.type
!= AR_FULL
6459 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6460 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6465 c
= ref
->u
.c
.component
;
6466 if (c
->ts
.type
== BT_CLASS
)
6468 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6469 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6473 allocatable
= c
->attr
.allocatable
;
6474 pointer
= c
->attr
.pointer
;
6484 attr
= gfc_expr_attr (e
);
6486 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6489 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6495 if (gfc_is_coindexed (e
))
6497 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6502 && !gfc_check_vardef_context (e
, true, true, false,
6503 _("DEALLOCATE object")))
6505 if (!gfc_check_vardef_context (e
, false, true, false,
6506 _("DEALLOCATE object")))
6513 /* Returns true if the expression e contains a reference to the symbol sym. */
6515 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6517 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6524 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6526 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6530 /* Given the expression node e for an allocatable/pointer of derived type to be
6531 allocated, get the expression node to be initialized afterwards (needed for
6532 derived types with default initializers, and derived types with allocatable
6533 components that need nullification.) */
6536 gfc_expr_to_initialize (gfc_expr
*e
)
6542 result
= gfc_copy_expr (e
);
6544 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6545 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6546 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6548 ref
->u
.ar
.type
= AR_FULL
;
6550 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6551 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6556 gfc_free_shape (&result
->shape
, result
->rank
);
6558 /* Recalculate rank, shape, etc. */
6559 gfc_resolve_expr (result
);
6564 /* If the last ref of an expression is an array ref, return a copy of the
6565 expression with that one removed. Otherwise, a copy of the original
6566 expression. This is used for allocate-expressions and pointer assignment
6567 LHS, where there may be an array specification that needs to be stripped
6568 off when using gfc_check_vardef_context. */
6571 remove_last_array_ref (gfc_expr
* e
)
6576 e2
= gfc_copy_expr (e
);
6577 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6578 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6580 gfc_free_ref_list (*r
);
6589 /* Used in resolve_allocate_expr to check that a allocation-object and
6590 a source-expr are conformable. This does not catch all possible
6591 cases; in particular a runtime checking is needed. */
6594 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6597 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6599 /* First compare rank. */
6600 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6602 gfc_error ("Source-expr at %L must be scalar or have the "
6603 "same rank as the allocate-object at %L",
6604 &e1
->where
, &e2
->where
);
6615 for (i
= 0; i
< e1
->rank
; i
++)
6617 if (tail
->u
.ar
.start
[i
] == NULL
)
6620 if (tail
->u
.ar
.end
[i
])
6622 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6623 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6624 mpz_add_ui (s
, s
, 1);
6628 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6631 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6633 gfc_error ("Source-expr at %L and allocate-object at %L must "
6634 "have the same shape", &e1
->where
, &e2
->where
);
6647 /* Resolve the expression in an ALLOCATE statement, doing the additional
6648 checks to see whether the expression is OK or not. The expression must
6649 have a trailing array reference that gives the size of the array. */
6652 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6654 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6658 symbol_attribute attr
;
6659 gfc_ref
*ref
, *ref2
;
6662 gfc_symbol
*sym
= NULL
;
6667 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6668 checking of coarrays. */
6669 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6670 if (ref
->next
== NULL
)
6673 if (ref
&& ref
->type
== REF_ARRAY
)
6674 ref
->u
.ar
.in_allocate
= true;
6676 if (!gfc_resolve_expr (e
))
6679 /* Make sure the expression is allocatable or a pointer. If it is
6680 pointer, the next-to-last reference must be a pointer. */
6684 sym
= e
->symtree
->n
.sym
;
6686 /* Check whether ultimate component is abstract and CLASS. */
6689 /* Is the allocate-object unlimited polymorphic? */
6690 unlimited
= UNLIMITED_POLY(e
);
6692 if (e
->expr_type
!= EXPR_VARIABLE
)
6695 attr
= gfc_expr_attr (e
);
6696 pointer
= attr
.pointer
;
6697 dimension
= attr
.dimension
;
6698 codimension
= attr
.codimension
;
6702 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6704 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6705 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6706 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6707 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6708 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6712 allocatable
= sym
->attr
.allocatable
;
6713 pointer
= sym
->attr
.pointer
;
6714 dimension
= sym
->attr
.dimension
;
6715 codimension
= sym
->attr
.codimension
;
6720 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6725 if (ref
->u
.ar
.codimen
> 0)
6728 for (n
= ref
->u
.ar
.dimen
;
6729 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6730 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6737 if (ref
->next
!= NULL
)
6745 gfc_error ("Coindexed allocatable object at %L",
6750 c
= ref
->u
.c
.component
;
6751 if (c
->ts
.type
== BT_CLASS
)
6753 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6754 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6755 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6756 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6757 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6761 allocatable
= c
->attr
.allocatable
;
6762 pointer
= c
->attr
.pointer
;
6763 dimension
= c
->attr
.dimension
;
6764 codimension
= c
->attr
.codimension
;
6765 is_abstract
= c
->attr
.abstract
;
6777 /* Check for F08:C628. */
6778 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6780 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6785 /* Some checks for the SOURCE tag. */
6788 /* Check F03:C631. */
6789 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6791 gfc_error ("Type of entity at %L is type incompatible with "
6792 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6796 /* Check F03:C632 and restriction following Note 6.18. */
6797 if (code
->expr3
->rank
> 0 && !unlimited
6798 && !conformable_arrays (code
->expr3
, e
))
6801 /* Check F03:C633. */
6802 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6804 gfc_error ("The allocate-object at %L and the source-expr at %L "
6805 "shall have the same kind type parameter",
6806 &e
->where
, &code
->expr3
->where
);
6810 /* Check F2008, C642. */
6811 if (code
->expr3
->ts
.type
== BT_DERIVED
6812 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6813 || (code
->expr3
->ts
.u
.derived
->from_intmod
6814 == INTMOD_ISO_FORTRAN_ENV
6815 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6816 == ISOFORTRAN_LOCK_TYPE
)))
6818 gfc_error ("The source-expr at %L shall neither be of type "
6819 "LOCK_TYPE nor have a LOCK_TYPE component if "
6820 "allocate-object at %L is a coarray",
6821 &code
->expr3
->where
, &e
->where
);
6826 /* Check F08:C629. */
6827 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6830 gcc_assert (e
->ts
.type
== BT_CLASS
);
6831 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6832 "type-spec or source-expr", sym
->name
, &e
->where
);
6836 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6838 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6839 code
->ext
.alloc
.ts
.u
.cl
->length
);
6840 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6842 gfc_error ("Allocating %s at %L with type-spec requires the same "
6843 "character-length parameter as in the declaration",
6844 sym
->name
, &e
->where
);
6849 /* In the variable definition context checks, gfc_expr_attr is used
6850 on the expression. This is fooled by the array specification
6851 present in e, thus we have to eliminate that one temporarily. */
6852 e2
= remove_last_array_ref (e
);
6855 t
= gfc_check_vardef_context (e2
, true, true, false,
6856 _("ALLOCATE object"));
6858 t
= gfc_check_vardef_context (e2
, false, true, false,
6859 _("ALLOCATE object"));
6864 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6865 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6867 /* For class arrays, the initialization with SOURCE is done
6868 using _copy and trans_call. It is convenient to exploit that
6869 when the allocated type is different from the declared type but
6870 no SOURCE exists by setting expr3. */
6871 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6873 else if (!code
->expr3
)
6875 /* Set up default initializer if needed. */
6879 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6880 ts
= code
->ext
.alloc
.ts
;
6884 if (ts
.type
== BT_CLASS
)
6885 ts
= ts
.u
.derived
->components
->ts
;
6887 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6889 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6890 init_st
->loc
= code
->loc
;
6891 init_st
->expr1
= gfc_expr_to_initialize (e
);
6892 init_st
->expr2
= init_e
;
6893 init_st
->next
= code
->next
;
6894 code
->next
= init_st
;
6897 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6899 /* Default initialization via MOLD (non-polymorphic). */
6900 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6901 gfc_resolve_expr (rhs
);
6902 gfc_free_expr (code
->expr3
);
6906 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6908 /* Make sure the vtab symbol is present when
6909 the module variables are generated. */
6910 gfc_typespec ts
= e
->ts
;
6912 ts
= code
->expr3
->ts
;
6913 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6914 ts
= code
->ext
.alloc
.ts
;
6916 gfc_find_derived_vtab (ts
.u
.derived
);
6919 e
= gfc_expr_to_initialize (e
);
6921 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6923 /* Again, make sure the vtab symbol is present when
6924 the module variables are generated. */
6925 gfc_typespec
*ts
= NULL
;
6927 ts
= &code
->expr3
->ts
;
6929 ts
= &code
->ext
.alloc
.ts
;
6933 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6934 gfc_find_derived_vtab (ts
->u
.derived
);
6936 gfc_find_intrinsic_vtab (ts
);
6939 e
= gfc_expr_to_initialize (e
);
6942 if (dimension
== 0 && codimension
== 0)
6945 /* Make sure the last reference node is an array specification. */
6947 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6948 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6950 gfc_error ("Array specification required in ALLOCATE statement "
6951 "at %L", &e
->where
);
6955 /* Make sure that the array section reference makes sense in the
6956 context of an ALLOCATE specification. */
6961 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6962 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6964 gfc_error ("Coarray specification required in ALLOCATE statement "
6965 "at %L", &e
->where
);
6969 for (i
= 0; i
< ar
->dimen
; i
++)
6971 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6974 switch (ar
->dimen_type
[i
])
6980 if (ar
->start
[i
] != NULL
6981 && ar
->end
[i
] != NULL
6982 && ar
->stride
[i
] == NULL
)
6985 /* Fall Through... */
6990 case DIMEN_THIS_IMAGE
:
6991 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6997 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6999 sym
= a
->expr
->symtree
->n
.sym
;
7001 /* TODO - check derived type components. */
7002 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7005 if ((ar
->start
[i
] != NULL
7006 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7007 || (ar
->end
[i
] != NULL
7008 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7010 gfc_error ("'%s' must not appear in the array specification at "
7011 "%L in the same ALLOCATE statement where it is "
7012 "itself allocated", sym
->name
, &ar
->where
);
7018 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7020 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7021 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7023 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7025 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7026 "statement at %L", &e
->where
);
7032 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7033 && ar
->stride
[i
] == NULL
)
7036 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7049 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7051 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7052 gfc_alloc
*a
, *p
, *q
;
7055 errmsg
= code
->expr2
;
7057 /* Check the stat variable. */
7060 gfc_check_vardef_context (stat
, false, false, false,
7061 _("STAT variable"));
7063 if ((stat
->ts
.type
!= BT_INTEGER
7064 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7065 || stat
->ref
->type
== REF_COMPONENT
)))
7067 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7068 "variable", &stat
->where
);
7070 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7071 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7073 gfc_ref
*ref1
, *ref2
;
7076 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7077 ref1
= ref1
->next
, ref2
= ref2
->next
)
7079 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7081 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7090 gfc_error ("Stat-variable at %L shall not be %sd within "
7091 "the same %s statement", &stat
->where
, fcn
, fcn
);
7097 /* Check the errmsg variable. */
7101 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7104 gfc_check_vardef_context (errmsg
, false, false, false,
7105 _("ERRMSG variable"));
7107 if ((errmsg
->ts
.type
!= BT_CHARACTER
7109 && (errmsg
->ref
->type
== REF_ARRAY
7110 || errmsg
->ref
->type
== REF_COMPONENT
)))
7111 || errmsg
->rank
> 0 )
7112 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7113 "variable", &errmsg
->where
);
7115 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7116 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7118 gfc_ref
*ref1
, *ref2
;
7121 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7122 ref1
= ref1
->next
, ref2
= ref2
->next
)
7124 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7126 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7135 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7136 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7142 /* Check that an allocate-object appears only once in the statement. */
7144 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7147 for (q
= p
->next
; q
; q
= q
->next
)
7150 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7152 /* This is a potential collision. */
7153 gfc_ref
*pr
= pe
->ref
;
7154 gfc_ref
*qr
= qe
->ref
;
7156 /* Follow the references until
7157 a) They start to differ, in which case there is no error;
7158 you can deallocate a%b and a%c in a single statement
7159 b) Both of them stop, which is an error
7160 c) One of them stops, which is also an error. */
7163 if (pr
== NULL
&& qr
== NULL
)
7165 gfc_error ("Allocate-object at %L also appears at %L",
7166 &pe
->where
, &qe
->where
);
7169 else if (pr
!= NULL
&& qr
== NULL
)
7171 gfc_error ("Allocate-object at %L is subobject of"
7172 " object at %L", &pe
->where
, &qe
->where
);
7175 else if (pr
== NULL
&& qr
!= NULL
)
7177 gfc_error ("Allocate-object at %L is subobject of"
7178 " object at %L", &qe
->where
, &pe
->where
);
7181 /* Here, pr != NULL && qr != NULL */
7182 gcc_assert(pr
->type
== qr
->type
);
7183 if (pr
->type
== REF_ARRAY
)
7185 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7187 gcc_assert (qr
->type
== REF_ARRAY
);
7189 if (pr
->next
&& qr
->next
)
7192 gfc_array_ref
*par
= &(pr
->u
.ar
);
7193 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7195 for (i
=0; i
<par
->dimen
; i
++)
7197 if ((par
->start
[i
] != NULL
7198 || qar
->start
[i
] != NULL
)
7199 && gfc_dep_compare_expr (par
->start
[i
],
7200 qar
->start
[i
]) != 0)
7207 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7220 if (strcmp (fcn
, "ALLOCATE") == 0)
7222 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7223 resolve_allocate_expr (a
->expr
, code
);
7227 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7228 resolve_deallocate_expr (a
->expr
);
7233 /************ SELECT CASE resolution subroutines ************/
7235 /* Callback function for our mergesort variant. Determines interval
7236 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7237 op1 > op2. Assumes we're not dealing with the default case.
7238 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7239 There are nine situations to check. */
7242 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7246 if (op1
->low
== NULL
) /* op1 = (:L) */
7248 /* op2 = (:N), so overlap. */
7250 /* op2 = (M:) or (M:N), L < M */
7251 if (op2
->low
!= NULL
7252 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7255 else if (op1
->high
== NULL
) /* op1 = (K:) */
7257 /* op2 = (M:), so overlap. */
7259 /* op2 = (:N) or (M:N), K > N */
7260 if (op2
->high
!= NULL
7261 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7264 else /* op1 = (K:L) */
7266 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7267 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7269 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7270 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7272 else /* op2 = (M:N) */
7276 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7279 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7288 /* Merge-sort a double linked case list, detecting overlap in the
7289 process. LIST is the head of the double linked case list before it
7290 is sorted. Returns the head of the sorted list if we don't see any
7291 overlap, or NULL otherwise. */
7294 check_case_overlap (gfc_case
*list
)
7296 gfc_case
*p
, *q
, *e
, *tail
;
7297 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7299 /* If the passed list was empty, return immediately. */
7306 /* Loop unconditionally. The only exit from this loop is a return
7307 statement, when we've finished sorting the case list. */
7314 /* Count the number of merges we do in this pass. */
7317 /* Loop while there exists a merge to be done. */
7322 /* Count this merge. */
7325 /* Cut the list in two pieces by stepping INSIZE places
7326 forward in the list, starting from P. */
7329 for (i
= 0; i
< insize
; i
++)
7338 /* Now we have two lists. Merge them! */
7339 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7341 /* See from which the next case to merge comes from. */
7344 /* P is empty so the next case must come from Q. */
7349 else if (qsize
== 0 || q
== NULL
)
7358 cmp
= compare_cases (p
, q
);
7361 /* The whole case range for P is less than the
7369 /* The whole case range for Q is greater than
7370 the case range for P. */
7377 /* The cases overlap, or they are the same
7378 element in the list. Either way, we must
7379 issue an error and get the next case from P. */
7380 /* FIXME: Sort P and Q by line number. */
7381 gfc_error ("CASE label at %L overlaps with CASE "
7382 "label at %L", &p
->where
, &q
->where
);
7390 /* Add the next element to the merged list. */
7399 /* P has now stepped INSIZE places along, and so has Q. So
7400 they're the same. */
7405 /* If we have done only one merge or none at all, we've
7406 finished sorting the cases. */
7415 /* Otherwise repeat, merging lists twice the size. */
7421 /* Check to see if an expression is suitable for use in a CASE statement.
7422 Makes sure that all case expressions are scalar constants of the same
7423 type. Return false if anything is wrong. */
7426 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7428 if (e
== NULL
) return true;
7430 if (e
->ts
.type
!= case_expr
->ts
.type
)
7432 gfc_error ("Expression in CASE statement at %L must be of type %s",
7433 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7437 /* C805 (R808) For a given case-construct, each case-value shall be of
7438 the same type as case-expr. For character type, length differences
7439 are allowed, but the kind type parameters shall be the same. */
7441 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7443 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7444 &e
->where
, case_expr
->ts
.kind
);
7448 /* Convert the case value kind to that of case expression kind,
7451 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7452 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7456 gfc_error ("Expression in CASE statement at %L must be scalar",
7465 /* Given a completely parsed select statement, we:
7467 - Validate all expressions and code within the SELECT.
7468 - Make sure that the selection expression is not of the wrong type.
7469 - Make sure that no case ranges overlap.
7470 - Eliminate unreachable cases and unreachable code resulting from
7471 removing case labels.
7473 The standard does allow unreachable cases, e.g. CASE (5:3). But
7474 they are a hassle for code generation, and to prevent that, we just
7475 cut them out here. This is not necessary for overlapping cases
7476 because they are illegal and we never even try to generate code.
7478 We have the additional caveat that a SELECT construct could have
7479 been a computed GOTO in the source code. Fortunately we can fairly
7480 easily work around that here: The case_expr for a "real" SELECT CASE
7481 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7482 we have to do is make sure that the case_expr is a scalar integer
7486 resolve_select (gfc_code
*code
, bool select_type
)
7489 gfc_expr
*case_expr
;
7490 gfc_case
*cp
, *default_case
, *tail
, *head
;
7491 int seen_unreachable
;
7497 if (code
->expr1
== NULL
)
7499 /* This was actually a computed GOTO statement. */
7500 case_expr
= code
->expr2
;
7501 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7502 gfc_error ("Selection expression in computed GOTO statement "
7503 "at %L must be a scalar integer expression",
7506 /* Further checking is not necessary because this SELECT was built
7507 by the compiler, so it should always be OK. Just move the
7508 case_expr from expr2 to expr so that we can handle computed
7509 GOTOs as normal SELECTs from here on. */
7510 code
->expr1
= code
->expr2
;
7515 case_expr
= code
->expr1
;
7516 type
= case_expr
->ts
.type
;
7519 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7521 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7522 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7524 /* Punt. Going on here just produce more garbage error messages. */
7529 if (!select_type
&& case_expr
->rank
!= 0)
7531 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7532 "expression", &case_expr
->where
);
7538 /* Raise a warning if an INTEGER case value exceeds the range of
7539 the case-expr. Later, all expressions will be promoted to the
7540 largest kind of all case-labels. */
7542 if (type
== BT_INTEGER
)
7543 for (body
= code
->block
; body
; body
= body
->block
)
7544 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7547 && gfc_check_integer_range (cp
->low
->value
.integer
,
7548 case_expr
->ts
.kind
) != ARITH_OK
)
7549 gfc_warning ("Expression in CASE statement at %L is "
7550 "not in the range of %s", &cp
->low
->where
,
7551 gfc_typename (&case_expr
->ts
));
7554 && cp
->low
!= cp
->high
7555 && gfc_check_integer_range (cp
->high
->value
.integer
,
7556 case_expr
->ts
.kind
) != ARITH_OK
)
7557 gfc_warning ("Expression in CASE statement at %L is "
7558 "not in the range of %s", &cp
->high
->where
,
7559 gfc_typename (&case_expr
->ts
));
7562 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7563 of the SELECT CASE expression and its CASE values. Walk the lists
7564 of case values, and if we find a mismatch, promote case_expr to
7565 the appropriate kind. */
7567 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7569 for (body
= code
->block
; body
; body
= body
->block
)
7571 /* Walk the case label list. */
7572 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7574 /* Intercept the DEFAULT case. It does not have a kind. */
7575 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7578 /* Unreachable case ranges are discarded, so ignore. */
7579 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7580 && cp
->low
!= cp
->high
7581 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7585 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7586 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7588 if (cp
->high
!= NULL
7589 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7590 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7595 /* Assume there is no DEFAULT case. */
7596 default_case
= NULL
;
7601 for (body
= code
->block
; body
; body
= body
->block
)
7603 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7605 seen_unreachable
= 0;
7607 /* Walk the case label list, making sure that all case labels
7609 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7611 /* Count the number of cases in the whole construct. */
7614 /* Intercept the DEFAULT case. */
7615 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7617 if (default_case
!= NULL
)
7619 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7620 "by a second DEFAULT CASE at %L",
7621 &default_case
->where
, &cp
->where
);
7632 /* Deal with single value cases and case ranges. Errors are
7633 issued from the validation function. */
7634 if (!validate_case_label_expr (cp
->low
, case_expr
)
7635 || !validate_case_label_expr (cp
->high
, case_expr
))
7641 if (type
== BT_LOGICAL
7642 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7643 || cp
->low
!= cp
->high
))
7645 gfc_error ("Logical range in CASE statement at %L is not "
7646 "allowed", &cp
->low
->where
);
7651 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7654 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7655 if (value
& seen_logical
)
7657 gfc_error ("Constant logical value in CASE statement "
7658 "is repeated at %L",
7663 seen_logical
|= value
;
7666 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7667 && cp
->low
!= cp
->high
7668 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7670 if (gfc_option
.warn_surprising
)
7671 gfc_warning ("Range specification at %L can never "
7672 "be matched", &cp
->where
);
7674 cp
->unreachable
= 1;
7675 seen_unreachable
= 1;
7679 /* If the case range can be matched, it can also overlap with
7680 other cases. To make sure it does not, we put it in a
7681 double linked list here. We sort that with a merge sort
7682 later on to detect any overlapping cases. */
7686 head
->right
= head
->left
= NULL
;
7691 tail
->right
->left
= tail
;
7698 /* It there was a failure in the previous case label, give up
7699 for this case label list. Continue with the next block. */
7703 /* See if any case labels that are unreachable have been seen.
7704 If so, we eliminate them. This is a bit of a kludge because
7705 the case lists for a single case statement (label) is a
7706 single forward linked lists. */
7707 if (seen_unreachable
)
7709 /* Advance until the first case in the list is reachable. */
7710 while (body
->ext
.block
.case_list
!= NULL
7711 && body
->ext
.block
.case_list
->unreachable
)
7713 gfc_case
*n
= body
->ext
.block
.case_list
;
7714 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7716 gfc_free_case_list (n
);
7719 /* Strip all other unreachable cases. */
7720 if (body
->ext
.block
.case_list
)
7722 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7724 if (cp
->next
->unreachable
)
7726 gfc_case
*n
= cp
->next
;
7727 cp
->next
= cp
->next
->next
;
7729 gfc_free_case_list (n
);
7736 /* See if there were overlapping cases. If the check returns NULL,
7737 there was overlap. In that case we don't do anything. If head
7738 is non-NULL, we prepend the DEFAULT case. The sorted list can
7739 then used during code generation for SELECT CASE constructs with
7740 a case expression of a CHARACTER type. */
7743 head
= check_case_overlap (head
);
7745 /* Prepend the default_case if it is there. */
7746 if (head
!= NULL
&& default_case
)
7748 default_case
->left
= NULL
;
7749 default_case
->right
= head
;
7750 head
->left
= default_case
;
7754 /* Eliminate dead blocks that may be the result if we've seen
7755 unreachable case labels for a block. */
7756 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7758 if (body
->block
->ext
.block
.case_list
== NULL
)
7760 /* Cut the unreachable block from the code chain. */
7761 gfc_code
*c
= body
->block
;
7762 body
->block
= c
->block
;
7764 /* Kill the dead block, but not the blocks below it. */
7766 gfc_free_statements (c
);
7770 /* More than two cases is legal but insane for logical selects.
7771 Issue a warning for it. */
7772 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7774 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7779 /* Check if a derived type is extensible. */
7782 gfc_type_is_extensible (gfc_symbol
*sym
)
7784 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7785 || (sym
->attr
.is_class
7786 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7790 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7791 correct as well as possibly the array-spec. */
7794 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7798 gcc_assert (sym
->assoc
);
7799 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7801 /* If this is for SELECT TYPE, the target may not yet be set. In that
7802 case, return. Resolution will be called later manually again when
7804 target
= sym
->assoc
->target
;
7807 gcc_assert (!sym
->assoc
->dangling
);
7809 if (resolve_target
&& !gfc_resolve_expr (target
))
7812 /* For variable targets, we get some attributes from the target. */
7813 if (target
->expr_type
== EXPR_VARIABLE
)
7817 gcc_assert (target
->symtree
);
7818 tsym
= target
->symtree
->n
.sym
;
7820 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7821 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7823 sym
->attr
.target
= tsym
->attr
.target
7824 || gfc_expr_attr (target
).pointer
;
7827 /* Get type if this was not already set. Note that it can be
7828 some other type than the target in case this is a SELECT TYPE
7829 selector! So we must not update when the type is already there. */
7830 if (sym
->ts
.type
== BT_UNKNOWN
)
7831 sym
->ts
= target
->ts
;
7832 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7834 /* See if this is a valid association-to-variable. */
7835 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7836 && !gfc_has_vector_subscript (target
));
7838 /* Finally resolve if this is an array or not. */
7839 if (sym
->attr
.dimension
&& target
->rank
== 0)
7841 gfc_error ("Associate-name '%s' at %L is used as array",
7842 sym
->name
, &sym
->declared_at
);
7843 sym
->attr
.dimension
= 0;
7847 /* We cannot deal with class selectors that need temporaries. */
7848 if (target
->ts
.type
== BT_CLASS
7849 && gfc_ref_needs_temporary_p (target
->ref
))
7851 gfc_error ("CLASS selector at %L needs a temporary which is not "
7852 "yet implemented", &target
->where
);
7856 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7857 sym
->attr
.dimension
= 1;
7858 else if (target
->ts
.type
== BT_CLASS
)
7859 gfc_fix_class_refs (target
);
7861 /* The associate-name will have a correct type by now. Make absolutely
7862 sure that it has not picked up a dimension attribute. */
7863 if (sym
->ts
.type
== BT_CLASS
)
7864 sym
->attr
.dimension
= 0;
7866 if (sym
->attr
.dimension
)
7868 sym
->as
= gfc_get_array_spec ();
7869 sym
->as
->rank
= target
->rank
;
7870 sym
->as
->type
= AS_DEFERRED
;
7872 /* Target must not be coindexed, thus the associate-variable
7874 sym
->as
->corank
= 0;
7877 /* Mark this as an associate variable. */
7878 sym
->attr
.associate_var
= 1;
7880 /* If the target is a good class object, so is the associate variable. */
7881 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7882 sym
->attr
.class_ok
= 1;
7886 /* Resolve a SELECT TYPE statement. */
7889 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7891 gfc_symbol
*selector_type
;
7892 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7893 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7896 char name
[GFC_MAX_SYMBOL_LEN
];
7901 ns
= code
->ext
.block
.ns
;
7904 /* Check for F03:C813. */
7905 if (code
->expr1
->ts
.type
!= BT_CLASS
7906 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7908 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7909 "at %L", &code
->loc
);
7913 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7918 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7919 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7920 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7922 /* F2008: C803 The selector expression must not be coindexed. */
7923 if (gfc_is_coindexed (code
->expr2
))
7925 gfc_error ("Selector at %L must not be coindexed",
7926 &code
->expr2
->where
);
7933 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7935 if (gfc_is_coindexed (code
->expr1
))
7937 gfc_error ("Selector at %L must not be coindexed",
7938 &code
->expr1
->where
);
7943 /* Loop over TYPE IS / CLASS IS cases. */
7944 for (body
= code
->block
; body
; body
= body
->block
)
7946 c
= body
->ext
.block
.case_list
;
7948 /* Check F03:C815. */
7949 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7950 && !selector_type
->attr
.unlimited_polymorphic
7951 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7953 gfc_error ("Derived type '%s' at %L must be extensible",
7954 c
->ts
.u
.derived
->name
, &c
->where
);
7959 /* Check F03:C816. */
7960 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
7961 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
7962 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
7964 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7965 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7966 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7968 gfc_error ("Unexpected intrinsic type '%s' at %L",
7969 gfc_basic_typename (c
->ts
.type
), &c
->where
);
7974 /* Check F03:C814. */
7975 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
7977 gfc_error ("The type-spec at %L shall specify that each length "
7978 "type parameter is assumed", &c
->where
);
7983 /* Intercept the DEFAULT case. */
7984 if (c
->ts
.type
== BT_UNKNOWN
)
7986 /* Check F03:C818. */
7989 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7990 "by a second DEFAULT CASE at %L",
7991 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7996 default_case
= body
;
8003 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8004 target if present. If there are any EXIT statements referring to the
8005 SELECT TYPE construct, this is no problem because the gfc_code
8006 reference stays the same and EXIT is equally possible from the BLOCK
8007 it is changed to. */
8008 code
->op
= EXEC_BLOCK
;
8011 gfc_association_list
* assoc
;
8013 assoc
= gfc_get_association_list ();
8014 assoc
->st
= code
->expr1
->symtree
;
8015 assoc
->target
= gfc_copy_expr (code
->expr2
);
8016 assoc
->target
->where
= code
->expr2
->where
;
8017 /* assoc->variable will be set by resolve_assoc_var. */
8019 code
->ext
.block
.assoc
= assoc
;
8020 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8022 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8025 code
->ext
.block
.assoc
= NULL
;
8027 /* Add EXEC_SELECT to switch on type. */
8028 new_st
= gfc_get_code (code
->op
);
8029 new_st
->expr1
= code
->expr1
;
8030 new_st
->expr2
= code
->expr2
;
8031 new_st
->block
= code
->block
;
8032 code
->expr1
= code
->expr2
= NULL
;
8037 ns
->code
->next
= new_st
;
8039 code
->op
= EXEC_SELECT
;
8041 gfc_add_vptr_component (code
->expr1
);
8042 gfc_add_hash_component (code
->expr1
);
8044 /* Loop over TYPE IS / CLASS IS cases. */
8045 for (body
= code
->block
; body
; body
= body
->block
)
8047 c
= body
->ext
.block
.case_list
;
8049 if (c
->ts
.type
== BT_DERIVED
)
8050 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8051 c
->ts
.u
.derived
->hash_value
);
8052 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8057 ivtab
= gfc_find_intrinsic_vtab (&c
->ts
);
8058 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8059 e
= CLASS_DATA (ivtab
)->initializer
;
8060 c
->low
= c
->high
= gfc_copy_expr (e
);
8063 else if (c
->ts
.type
== BT_UNKNOWN
)
8066 /* Associate temporary to selector. This should only be done
8067 when this case is actually true, so build a new ASSOCIATE
8068 that does precisely this here (instead of using the
8071 if (c
->ts
.type
== BT_CLASS
)
8072 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8073 else if (c
->ts
.type
== BT_DERIVED
)
8074 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8075 else if (c
->ts
.type
== BT_CHARACTER
)
8077 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8078 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8079 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8080 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8081 charlen
, c
->ts
.kind
);
8084 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8087 st
= gfc_find_symtree (ns
->sym_root
, name
);
8088 gcc_assert (st
->n
.sym
->assoc
);
8089 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8090 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8091 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8092 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8094 new_st
= gfc_get_code (EXEC_BLOCK
);
8095 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8096 new_st
->ext
.block
.ns
->code
= body
->next
;
8097 body
->next
= new_st
;
8099 /* Chain in the new list only if it is marked as dangling. Otherwise
8100 there is a CASE label overlap and this is already used. Just ignore,
8101 the error is diagnosed elsewhere. */
8102 if (st
->n
.sym
->assoc
->dangling
)
8104 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8105 st
->n
.sym
->assoc
->dangling
= 0;
8108 resolve_assoc_var (st
->n
.sym
, false);
8111 /* Take out CLASS IS cases for separate treatment. */
8113 while (body
&& body
->block
)
8115 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8117 /* Add to class_is list. */
8118 if (class_is
== NULL
)
8120 class_is
= body
->block
;
8125 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8126 tail
->block
= body
->block
;
8129 /* Remove from EXEC_SELECT list. */
8130 body
->block
= body
->block
->block
;
8143 /* Add a default case to hold the CLASS IS cases. */
8144 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8145 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8147 tail
->ext
.block
.case_list
= gfc_get_case ();
8148 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8150 default_case
= tail
;
8153 /* More than one CLASS IS block? */
8154 if (class_is
->block
)
8158 /* Sort CLASS IS blocks by extension level. */
8162 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8165 /* F03:C817 (check for doubles). */
8166 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8167 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8169 gfc_error ("Double CLASS IS block in SELECT TYPE "
8171 &c2
->ext
.block
.case_list
->where
);
8174 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8175 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8178 (*c1
)->block
= c2
->block
;
8188 /* Generate IF chain. */
8189 if_st
= gfc_get_code (EXEC_IF
);
8191 for (body
= class_is
; body
; body
= body
->block
)
8193 new_st
->block
= gfc_get_code (EXEC_IF
);
8194 new_st
= new_st
->block
;
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 (EXEC_IF
);
8217 new_st
= new_st
->block
;
8218 new_st
->next
= default_case
->next
;
8221 /* Replace CLASS DEFAULT code by the IF chain. */
8222 default_case
->next
= if_st
;
8225 /* Resolve the internal code. This can not be done earlier because
8226 it requires that the sym->assoc of selectors is set already. */
8227 gfc_current_ns
= ns
;
8228 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8229 gfc_current_ns
= old_ns
;
8231 resolve_select (code
, true);
8235 /* Resolve a transfer statement. This is making sure that:
8236 -- a derived type being transferred has only non-pointer components
8237 -- a derived type being transferred doesn't have private components, unless
8238 it's being transferred from the module where the type was defined
8239 -- we're not trying to transfer a whole assumed size array. */
8242 resolve_transfer (gfc_code
*code
)
8251 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8252 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8253 exp
= exp
->value
.op
.op1
;
8255 if (exp
&& exp
->expr_type
== EXPR_NULL
8258 gfc_error ("Invalid context for NULL () intrinsic at %L",
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
)
9023 symbol_attribute attr
;
9025 if (gfc_extend_assign (code
, ns
))
9029 if (code
->op
== EXEC_ASSIGN_CALL
)
9031 lhs
= code
->ext
.actual
->expr
;
9032 rhsptr
= &code
->ext
.actual
->next
->expr
;
9036 gfc_actual_arglist
* args
;
9037 gfc_typebound_proc
* tbp
;
9039 gcc_assert (code
->op
== EXEC_COMPCALL
);
9041 args
= code
->expr1
->value
.compcall
.actual
;
9043 rhsptr
= &args
->next
->expr
;
9045 tbp
= code
->expr1
->value
.compcall
.tbp
;
9046 gcc_assert (!tbp
->is_generic
);
9049 /* Make a temporary rhs when there is a default initializer
9050 and rhs is the same symbol as the lhs. */
9051 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9052 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9053 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9054 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9055 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9064 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9065 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9069 /* Handle the case of a BOZ literal on the RHS. */
9070 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9073 if (gfc_option
.warn_surprising
)
9074 gfc_warning ("BOZ literal at %L is bitwise transferred "
9075 "non-integer symbol '%s'", &code
->loc
,
9076 lhs
->symtree
->n
.sym
->name
);
9078 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9080 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9082 if (rc
== ARITH_UNDERFLOW
)
9083 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9084 ". This check can be disabled with the option "
9085 "-fno-range-check", &rhs
->where
);
9086 else if (rc
== ARITH_OVERFLOW
)
9087 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9088 ". This check can be disabled with the option "
9089 "-fno-range-check", &rhs
->where
);
9090 else if (rc
== ARITH_NAN
)
9091 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9092 ". This check can be disabled with the option "
9093 "-fno-range-check", &rhs
->where
);
9098 if (lhs
->ts
.type
== BT_CHARACTER
9099 && gfc_option
.warn_character_truncation
)
9101 if (lhs
->ts
.u
.cl
!= NULL
9102 && lhs
->ts
.u
.cl
->length
!= NULL
9103 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9104 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9106 if (rhs
->expr_type
== EXPR_CONSTANT
)
9107 rlen
= rhs
->value
.character
.length
;
9109 else if (rhs
->ts
.u
.cl
!= NULL
9110 && rhs
->ts
.u
.cl
->length
!= NULL
9111 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9112 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9114 if (rlen
&& llen
&& rlen
> llen
)
9115 gfc_warning_now ("CHARACTER expression will be truncated "
9116 "in assignment (%d/%d) at %L",
9117 llen
, rlen
, &code
->loc
);
9120 /* Ensure that a vector index expression for the lvalue is evaluated
9121 to a temporary if the lvalue symbol is referenced in it. */
9124 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9125 if (ref
->type
== REF_ARRAY
)
9127 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9128 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9129 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9130 ref
->u
.ar
.start
[n
]))
9132 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9136 if (gfc_pure (NULL
))
9138 if (lhs
->ts
.type
== BT_DERIVED
9139 && lhs
->expr_type
== EXPR_VARIABLE
9140 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9141 && rhs
->expr_type
== EXPR_VARIABLE
9142 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9143 || gfc_is_coindexed (rhs
)))
9146 if (gfc_is_coindexed (rhs
))
9147 gfc_error ("Coindexed expression at %L is assigned to "
9148 "a derived type variable with a POINTER "
9149 "component in a PURE procedure",
9152 gfc_error ("The impure variable at %L is assigned to "
9153 "a derived type variable with a POINTER "
9154 "component in a PURE procedure (12.6)",
9159 /* Fortran 2008, C1283. */
9160 if (gfc_is_coindexed (lhs
))
9162 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9163 "procedure", &rhs
->where
);
9168 if (gfc_implicit_pure (NULL
))
9170 if (lhs
->expr_type
== EXPR_VARIABLE
9171 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9172 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9173 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9175 if (lhs
->ts
.type
== BT_DERIVED
9176 && lhs
->expr_type
== EXPR_VARIABLE
9177 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9178 && rhs
->expr_type
== EXPR_VARIABLE
9179 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9180 || gfc_is_coindexed (rhs
)))
9181 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9183 /* Fortran 2008, C1283. */
9184 if (gfc_is_coindexed (lhs
))
9185 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9188 /* F2008, 7.2.1.2. */
9189 attr
= gfc_expr_attr (lhs
);
9190 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9192 if (attr
.codimension
)
9194 gfc_error ("Assignment to polymorphic coarray at %L is not "
9195 "permitted", &lhs
->where
);
9198 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9199 "polymorphic variable at %L", &lhs
->where
))
9201 if (!gfc_option
.flag_realloc_lhs
)
9203 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9204 "requires -frealloc-lhs", &lhs
->where
);
9208 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9209 "is not yet supported", &lhs
->where
);
9212 else if (lhs
->ts
.type
== BT_CLASS
)
9214 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9215 "assignment at %L - check that there is a matching specific "
9216 "subroutine for '=' operator", &lhs
->where
);
9220 /* F2008, Section 7.2.1.2. */
9221 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9223 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9224 "component in assignment at %L", &lhs
->where
);
9228 gfc_check_assign (lhs
, rhs
, 1);
9233 /* Add a component reference onto an expression. */
9236 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9241 ref
= &((*ref
)->next
);
9242 *ref
= gfc_get_ref ();
9243 (*ref
)->type
= REF_COMPONENT
;
9244 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9245 (*ref
)->u
.c
.component
= c
;
9248 /* Add a full array ref, as necessary. */
9251 gfc_add_full_array_ref (e
, c
->as
);
9252 e
->rank
= c
->as
->rank
;
9257 /* Build an assignment. Keep the argument 'op' for future use, so that
9258 pointer assignments can be made. */
9261 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9262 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9264 gfc_code
*this_code
;
9266 this_code
= gfc_get_code (op
);
9267 this_code
->next
= NULL
;
9268 this_code
->expr1
= gfc_copy_expr (expr1
);
9269 this_code
->expr2
= gfc_copy_expr (expr2
);
9270 this_code
->loc
= loc
;
9273 add_comp_ref (this_code
->expr1
, comp1
);
9274 add_comp_ref (this_code
->expr2
, comp2
);
9281 /* Makes a temporary variable expression based on the characteristics of
9282 a given variable expression. */
9285 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9287 static int serial
= 0;
9288 char name
[GFC_MAX_SYMBOL_LEN
];
9291 gfc_array_ref
*aref
;
9294 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9295 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9296 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9302 /* This function could be expanded to support other expression type
9303 but this is not needed here. */
9304 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9306 /* Obtain the arrayspec for the temporary. */
9309 aref
= gfc_find_array_ref (e
);
9310 if (e
->expr_type
== EXPR_VARIABLE
9311 && e
->symtree
->n
.sym
->as
== aref
->as
)
9315 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9316 if (ref
->type
== REF_COMPONENT
9317 && ref
->u
.c
.component
->as
== aref
->as
)
9325 /* Add the attributes and the arrayspec to the temporary. */
9326 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9327 tmp
->n
.sym
->attr
.function
= 0;
9328 tmp
->n
.sym
->attr
.result
= 0;
9329 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9333 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9336 if (as
->type
== AS_DEFERRED
)
9337 tmp
->n
.sym
->attr
.allocatable
= 1;
9340 tmp
->n
.sym
->attr
.dimension
= 0;
9342 gfc_set_sym_referenced (tmp
->n
.sym
);
9343 gfc_commit_symbol (tmp
->n
.sym
);
9344 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9346 /* Should the lhs be a section, use its array ref for the
9347 temporary expression. */
9348 if (aref
&& aref
->type
!= AR_FULL
)
9350 gfc_free_ref_list (e
->ref
);
9351 e
->ref
= gfc_copy_ref (ref
);
9357 /* Add one line of code to the code chain, making sure that 'head' and
9358 'tail' are appropriately updated. */
9361 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9363 gcc_assert (this_code
);
9365 *head
= *tail
= *this_code
;
9367 *tail
= gfc_append_code (*tail
, *this_code
);
9372 /* Counts the potential number of part array references that would
9373 result from resolution of typebound defined assignments. */
9376 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9379 int c_depth
= 0, t_depth
;
9381 for (c
= derived
->components
; c
; c
= c
->next
)
9383 if ((c
->ts
.type
!= BT_DERIVED
9385 || c
->attr
.allocatable
9386 || c
->attr
.proc_pointer_comp
9387 || c
->attr
.class_pointer
9388 || c
->attr
.proc_pointer
)
9389 && !c
->attr
.defined_assign_comp
)
9392 if (c
->as
&& c_depth
== 0)
9395 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9396 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9401 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9403 return depth
+ c_depth
;
9407 /* Implement 7.2.1.3 of the F08 standard:
9408 "An intrinsic assignment where the variable is of derived type is
9409 performed as if each component of the variable were assigned from the
9410 corresponding component of expr using pointer assignment (7.2.2) for
9411 each pointer component, defined assignment for each nonpointer
9412 nonallocatable component of a type that has a type-bound defined
9413 assignment consistent with the component, intrinsic assignment for
9414 each other nonpointer nonallocatable component, ..."
9416 The pointer assignments are taken care of by the intrinsic
9417 assignment of the structure itself. This function recursively adds
9418 defined assignments where required. The recursion is accomplished
9419 by calling resolve_code.
9421 When the lhs in a defined assignment has intent INOUT, we need a
9422 temporary for the lhs. In pseudo-code:
9424 ! Only call function lhs once.
9425 if (lhs is not a constant or an variable)
9428 ! Do the intrinsic assignment
9430 ! Now do the defined assignments
9431 do over components with typebound defined assignment [%cmp]
9432 #if one component's assignment procedure is INOUT
9434 #if expr2 non-variable
9440 t1%cmp {defined=} expr2%cmp
9446 expr1%cmp {defined=} expr2%cmp
9450 /* The temporary assignments have to be put on top of the additional
9451 code to avoid the result being changed by the intrinsic assignment.
9453 static int component_assignment_level
= 0;
9454 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9457 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9459 gfc_component
*comp1
, *comp2
;
9460 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9462 int error_count
, depth
;
9464 gfc_get_errors (NULL
, &error_count
);
9466 /* Filter out continuing processing after an error. */
9468 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9469 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9472 /* TODO: Handle more than one part array reference in assignments. */
9473 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9474 (*code
)->expr1
->rank
? 1 : 0);
9477 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9478 "done because multiple part array references would "
9479 "occur in intermediate expressions.", &(*code
)->loc
);
9483 component_assignment_level
++;
9485 /* Create a temporary so that functions get called only once. */
9486 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9487 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9491 /* Assign the rhs to the temporary. */
9492 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9493 this_code
= build_assignment (EXEC_ASSIGN
,
9494 tmp_expr
, (*code
)->expr2
,
9495 NULL
, NULL
, (*code
)->loc
);
9496 /* Add the code and substitute the rhs expression. */
9497 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9498 gfc_free_expr ((*code
)->expr2
);
9499 (*code
)->expr2
= tmp_expr
;
9502 /* Do the intrinsic assignment. This is not needed if the lhs is one
9503 of the temporaries generated here, since the intrinsic assignment
9504 to the final result already does this. */
9505 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9507 this_code
= build_assignment (EXEC_ASSIGN
,
9508 (*code
)->expr1
, (*code
)->expr2
,
9509 NULL
, NULL
, (*code
)->loc
);
9510 add_code_to_chain (&this_code
, &head
, &tail
);
9513 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9514 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9517 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9521 /* The intrinsic assignment does the right thing for pointers
9522 of all kinds and allocatable components. */
9523 if (comp1
->ts
.type
!= BT_DERIVED
9524 || comp1
->attr
.pointer
9525 || comp1
->attr
.allocatable
9526 || comp1
->attr
.proc_pointer_comp
9527 || comp1
->attr
.class_pointer
9528 || comp1
->attr
.proc_pointer
)
9531 /* Make an assigment for this component. */
9532 this_code
= build_assignment (EXEC_ASSIGN
,
9533 (*code
)->expr1
, (*code
)->expr2
,
9534 comp1
, comp2
, (*code
)->loc
);
9536 /* Convert the assignment if there is a defined assignment for
9537 this type. Otherwise, using the call from resolve_code,
9538 recurse into its components. */
9539 resolve_code (this_code
, ns
);
9541 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9543 gfc_formal_arglist
*dummy_args
;
9545 /* Check that there is a typebound defined assignment. If not,
9546 then this must be a module defined assignment. We cannot
9547 use the defined_assign_comp attribute here because it must
9548 be this derived type that has the defined assignment and not
9550 if (!(comp1
->ts
.u
.derived
->f2k_derived
9551 && comp1
->ts
.u
.derived
->f2k_derived
9552 ->tb_op
[INTRINSIC_ASSIGN
]))
9554 gfc_free_statements (this_code
);
9559 /* If the first argument of the subroutine has intent INOUT
9560 a temporary must be generated and used instead. */
9561 rsym
= this_code
->resolved_sym
;
9562 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9564 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9566 gfc_code
*temp_code
;
9569 /* Build the temporary required for the assignment and put
9570 it at the head of the generated code. */
9573 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9574 temp_code
= build_assignment (EXEC_ASSIGN
,
9576 NULL
, NULL
, (*code
)->loc
);
9578 /* For allocatable LHS, check whether it is allocated. Note
9579 that allocatable components with defined assignment are
9580 not yet support. See PR 57696. */
9581 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9585 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9586 block
= gfc_get_code (EXEC_IF
);
9587 block
->block
= gfc_get_code (EXEC_IF
);
9589 = gfc_build_intrinsic_call (ns
,
9590 GFC_ISYM_ALLOCATED
, "allocated",
9591 (*code
)->loc
, 1, e
);
9592 block
->block
->next
= temp_code
;
9595 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9598 /* Replace the first actual arg with the component of the
9600 gfc_free_expr (this_code
->ext
.actual
->expr
);
9601 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9602 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9604 /* If the LHS variable is allocatable and wasn't allocated and
9605 the temporary is allocatable, pointer assign the address of
9606 the freshly allocated LHS to the temporary. */
9607 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9608 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9613 cond
= gfc_get_expr ();
9614 cond
->ts
.type
= BT_LOGICAL
;
9615 cond
->ts
.kind
= gfc_default_logical_kind
;
9616 cond
->expr_type
= EXPR_OP
;
9617 cond
->where
= (*code
)->loc
;
9618 cond
->value
.op
.op
= INTRINSIC_NOT
;
9619 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9620 GFC_ISYM_ALLOCATED
, "allocated",
9621 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9622 block
= gfc_get_code (EXEC_IF
);
9623 block
->block
= gfc_get_code (EXEC_IF
);
9624 block
->block
->expr1
= cond
;
9625 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9627 NULL
, NULL
, (*code
)->loc
);
9628 add_code_to_chain (&block
, &head
, &tail
);
9632 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9634 /* Don't add intrinsic assignments since they are already
9635 effected by the intrinsic assignment of the structure. */
9636 gfc_free_statements (this_code
);
9641 add_code_to_chain (&this_code
, &head
, &tail
);
9645 /* Transfer the value to the final result. */
9646 this_code
= build_assignment (EXEC_ASSIGN
,
9648 comp1
, comp2
, (*code
)->loc
);
9649 add_code_to_chain (&this_code
, &head
, &tail
);
9653 /* Put the temporary assignments at the top of the generated code. */
9654 if (tmp_head
&& component_assignment_level
== 1)
9656 gfc_append_code (tmp_head
, head
);
9658 tmp_head
= tmp_tail
= NULL
;
9661 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9662 // not accidentally deallocated. Hence, nullify t1.
9663 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9664 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9670 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9671 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9672 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9673 block
= gfc_get_code (EXEC_IF
);
9674 block
->block
= gfc_get_code (EXEC_IF
);
9675 block
->block
->expr1
= cond
;
9676 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9677 t1
, gfc_get_null_expr (&(*code
)->loc
),
9678 NULL
, NULL
, (*code
)->loc
);
9679 gfc_append_code (tail
, block
);
9683 /* Now attach the remaining code chain to the input code. Step on
9684 to the end of the new code since resolution is complete. */
9685 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9686 tail
->next
= (*code
)->next
;
9687 /* Overwrite 'code' because this would place the intrinsic assignment
9688 before the temporary for the lhs is created. */
9689 gfc_free_expr ((*code
)->expr1
);
9690 gfc_free_expr ((*code
)->expr2
);
9696 component_assignment_level
--;
9700 /* Given a block of code, recursively resolve everything pointed to by this
9704 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9706 int omp_workshare_save
;
9707 int forall_save
, do_concurrent_save
;
9711 frame
.prev
= cs_base
;
9715 find_reachable_labels (code
);
9717 for (; code
; code
= code
->next
)
9719 frame
.current
= code
;
9720 forall_save
= forall_flag
;
9721 do_concurrent_save
= gfc_do_concurrent_flag
;
9723 if (code
->op
== EXEC_FORALL
)
9726 gfc_resolve_forall (code
, ns
, forall_save
);
9729 else if (code
->block
)
9731 omp_workshare_save
= -1;
9734 case EXEC_OMP_PARALLEL_WORKSHARE
:
9735 omp_workshare_save
= omp_workshare_flag
;
9736 omp_workshare_flag
= 1;
9737 gfc_resolve_omp_parallel_blocks (code
, ns
);
9739 case EXEC_OMP_PARALLEL
:
9740 case EXEC_OMP_PARALLEL_DO
:
9741 case EXEC_OMP_PARALLEL_SECTIONS
:
9743 omp_workshare_save
= omp_workshare_flag
;
9744 omp_workshare_flag
= 0;
9745 gfc_resolve_omp_parallel_blocks (code
, ns
);
9748 gfc_resolve_omp_do_blocks (code
, ns
);
9750 case EXEC_SELECT_TYPE
:
9751 /* Blocks are handled in resolve_select_type because we have
9752 to transform the SELECT TYPE into ASSOCIATE first. */
9754 case EXEC_DO_CONCURRENT
:
9755 gfc_do_concurrent_flag
= 1;
9756 gfc_resolve_blocks (code
->block
, ns
);
9757 gfc_do_concurrent_flag
= 2;
9759 case EXEC_OMP_WORKSHARE
:
9760 omp_workshare_save
= omp_workshare_flag
;
9761 omp_workshare_flag
= 1;
9764 gfc_resolve_blocks (code
->block
, ns
);
9768 if (omp_workshare_save
!= -1)
9769 omp_workshare_flag
= omp_workshare_save
;
9773 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9774 t
= gfc_resolve_expr (code
->expr1
);
9775 forall_flag
= forall_save
;
9776 gfc_do_concurrent_flag
= do_concurrent_save
;
9778 if (!gfc_resolve_expr (code
->expr2
))
9781 if (code
->op
== EXEC_ALLOCATE
9782 && !gfc_resolve_expr (code
->expr3
))
9788 case EXEC_END_BLOCK
:
9789 case EXEC_END_NESTED_BLOCK
:
9793 case EXEC_ERROR_STOP
:
9797 case EXEC_ASSIGN_CALL
:
9802 case EXEC_SYNC_IMAGES
:
9803 case EXEC_SYNC_MEMORY
:
9804 resolve_sync (code
);
9809 resolve_lock_unlock (code
);
9813 /* Keep track of which entry we are up to. */
9814 current_entry_id
= code
->ext
.entry
->id
;
9818 resolve_where (code
, NULL
);
9822 if (code
->expr1
!= NULL
)
9824 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9825 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9826 "INTEGER variable", &code
->expr1
->where
);
9827 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9828 gfc_error ("Variable '%s' has not been assigned a target "
9829 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9830 &code
->expr1
->where
);
9833 resolve_branch (code
->label1
, code
);
9837 if (code
->expr1
!= NULL
9838 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9839 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9840 "INTEGER return specifier", &code
->expr1
->where
);
9843 case EXEC_INIT_ASSIGN
:
9844 case EXEC_END_PROCEDURE
:
9851 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
9855 if (resolve_ordinary_assign (code
, ns
))
9857 if (code
->op
== EXEC_COMPCALL
)
9863 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
9864 if (code
->expr1
->ts
.type
== BT_DERIVED
9865 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
9866 generate_component_assignments (&code
, ns
);
9870 case EXEC_LABEL_ASSIGN
:
9871 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9872 gfc_error ("Label %d referenced at %L is never defined",
9873 code
->label1
->value
, &code
->label1
->where
);
9875 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9876 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9877 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9878 != gfc_default_integer_kind
9879 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9880 gfc_error ("ASSIGN statement at %L requires a scalar "
9881 "default INTEGER variable", &code
->expr1
->where
);
9884 case EXEC_POINTER_ASSIGN
:
9891 /* This is both a variable definition and pointer assignment
9892 context, so check both of them. For rank remapping, a final
9893 array ref may be present on the LHS and fool gfc_expr_attr
9894 used in gfc_check_vardef_context. Remove it. */
9895 e
= remove_last_array_ref (code
->expr1
);
9896 t
= gfc_check_vardef_context (e
, true, false, false,
9897 _("pointer assignment"));
9899 t
= gfc_check_vardef_context (e
, false, false, false,
9900 _("pointer assignment"));
9905 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9909 case EXEC_ARITHMETIC_IF
:
9911 && code
->expr1
->ts
.type
!= BT_INTEGER
9912 && code
->expr1
->ts
.type
!= BT_REAL
)
9913 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9914 "expression", &code
->expr1
->where
);
9916 resolve_branch (code
->label1
, code
);
9917 resolve_branch (code
->label2
, code
);
9918 resolve_branch (code
->label3
, code
);
9922 if (t
&& code
->expr1
!= NULL
9923 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9924 || code
->expr1
->rank
!= 0))
9925 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9926 &code
->expr1
->where
);
9931 resolve_call (code
);
9936 resolve_typebound_subroutine (code
);
9940 resolve_ppc_call (code
);
9944 /* Select is complicated. Also, a SELECT construct could be
9945 a transformed computed GOTO. */
9946 resolve_select (code
, false);
9949 case EXEC_SELECT_TYPE
:
9950 resolve_select_type (code
, ns
);
9954 resolve_block_construct (code
);
9958 if (code
->ext
.iterator
!= NULL
)
9960 gfc_iterator
*iter
= code
->ext
.iterator
;
9961 if (gfc_resolve_iterator (iter
, true, false))
9962 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9967 if (code
->expr1
== NULL
)
9968 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9970 && (code
->expr1
->rank
!= 0
9971 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9972 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9973 "a scalar LOGICAL expression", &code
->expr1
->where
);
9978 resolve_allocate_deallocate (code
, "ALLOCATE");
9982 case EXEC_DEALLOCATE
:
9984 resolve_allocate_deallocate (code
, "DEALLOCATE");
9989 if (!gfc_resolve_open (code
->ext
.open
))
9992 resolve_branch (code
->ext
.open
->err
, code
);
9996 if (!gfc_resolve_close (code
->ext
.close
))
9999 resolve_branch (code
->ext
.close
->err
, code
);
10002 case EXEC_BACKSPACE
:
10006 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10009 resolve_branch (code
->ext
.filepos
->err
, code
);
10013 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10016 resolve_branch (code
->ext
.inquire
->err
, code
);
10019 case EXEC_IOLENGTH
:
10020 gcc_assert (code
->ext
.inquire
!= NULL
);
10021 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10024 resolve_branch (code
->ext
.inquire
->err
, code
);
10028 if (!gfc_resolve_wait (code
->ext
.wait
))
10031 resolve_branch (code
->ext
.wait
->err
, code
);
10032 resolve_branch (code
->ext
.wait
->end
, code
);
10033 resolve_branch (code
->ext
.wait
->eor
, code
);
10038 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10041 resolve_branch (code
->ext
.dt
->err
, code
);
10042 resolve_branch (code
->ext
.dt
->end
, code
);
10043 resolve_branch (code
->ext
.dt
->eor
, code
);
10046 case EXEC_TRANSFER
:
10047 resolve_transfer (code
);
10050 case EXEC_DO_CONCURRENT
:
10052 resolve_forall_iterators (code
->ext
.forall_iterator
);
10054 if (code
->expr1
!= NULL
10055 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10056 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10057 "expression", &code
->expr1
->where
);
10060 case EXEC_OMP_ATOMIC
:
10061 case EXEC_OMP_BARRIER
:
10062 case EXEC_OMP_CRITICAL
:
10063 case EXEC_OMP_FLUSH
:
10065 case EXEC_OMP_MASTER
:
10066 case EXEC_OMP_ORDERED
:
10067 case EXEC_OMP_SECTIONS
:
10068 case EXEC_OMP_SINGLE
:
10069 case EXEC_OMP_TASKWAIT
:
10070 case EXEC_OMP_TASKYIELD
:
10071 case EXEC_OMP_WORKSHARE
:
10072 gfc_resolve_omp_directive (code
, ns
);
10075 case EXEC_OMP_PARALLEL
:
10076 case EXEC_OMP_PARALLEL_DO
:
10077 case EXEC_OMP_PARALLEL_SECTIONS
:
10078 case EXEC_OMP_PARALLEL_WORKSHARE
:
10079 case EXEC_OMP_TASK
:
10080 omp_workshare_save
= omp_workshare_flag
;
10081 omp_workshare_flag
= 0;
10082 gfc_resolve_omp_directive (code
, ns
);
10083 omp_workshare_flag
= omp_workshare_save
;
10087 gfc_internal_error ("resolve_code(): Bad statement code");
10091 cs_base
= frame
.prev
;
10095 /* Resolve initial values and make sure they are compatible with
10099 resolve_values (gfc_symbol
*sym
)
10103 if (sym
->value
== NULL
)
10106 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10107 t
= resolve_structure_cons (sym
->value
, 1);
10109 t
= gfc_resolve_expr (sym
->value
);
10114 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10118 /* Verify any BIND(C) derived types in the namespace so we can report errors
10119 for them once, rather than for each variable declared of that type. */
10122 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10124 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10125 && derived_sym
->attr
.is_bind_c
== 1)
10126 verify_bind_c_derived_type (derived_sym
);
10132 /* Verify that any binding labels used in a given namespace do not collide
10133 with the names or binding labels of any global symbols. Multiple INTERFACE
10134 for the same procedure are permitted. */
10137 gfc_verify_binding_labels (gfc_symbol
*sym
)
10140 const char *module
;
10142 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10143 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10146 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10149 module
= sym
->module
;
10150 else if (sym
->ns
&& sym
->ns
->proc_name
10151 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10152 module
= sym
->ns
->proc_name
->name
;
10153 else if (sym
->ns
&& sym
->ns
->parent
10154 && sym
->ns
&& sym
->ns
->parent
->proc_name
10155 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10156 module
= sym
->ns
->parent
->proc_name
->name
;
10162 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10165 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10166 gsym
->where
= sym
->declared_at
;
10167 gsym
->sym_name
= sym
->name
;
10168 gsym
->binding_label
= sym
->binding_label
;
10169 gsym
->binding_label
= sym
->binding_label
;
10170 gsym
->ns
= sym
->ns
;
10171 gsym
->mod_name
= module
;
10172 if (sym
->attr
.function
)
10173 gsym
->type
= GSYM_FUNCTION
;
10174 else if (sym
->attr
.subroutine
)
10175 gsym
->type
= GSYM_SUBROUTINE
;
10176 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10177 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10181 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10183 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10184 "identifier as entity at %L", sym
->name
,
10185 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10186 /* Clear the binding label to prevent checking multiple times. */
10187 sym
->binding_label
= NULL
;
10190 else if (sym
->attr
.flavor
== FL_VARIABLE
10191 && (strcmp (module
, gsym
->mod_name
) != 0
10192 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10194 /* This can only happen if the variable is defined in a module - if it
10195 isn't the same module, reject it. */
10196 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10197 "the same global identifier as entity at %L from module %s",
10198 sym
->name
, module
, sym
->binding_label
,
10199 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10200 sym
->binding_label
= NULL
;
10202 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10203 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10204 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10205 && sym
!= gsym
->ns
->proc_name
10206 && (strcmp (gsym
->sym_name
, sym
->name
) != 0
10207 || module
!= gsym
->mod_name
10208 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10210 /* Print an error if the procdure is defined multiple times; we have to
10211 exclude references to the same procedure via module association or
10212 multiple checks for the same procedure. */
10213 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10214 "global identifier as entity at %L", sym
->name
,
10215 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10216 sym
->binding_label
= NULL
;
10221 /* Resolve an index expression. */
10224 resolve_index_expr (gfc_expr
*e
)
10226 if (!gfc_resolve_expr (e
))
10229 if (!gfc_simplify_expr (e
, 0))
10232 if (!gfc_specification_expr (e
))
10239 /* Resolve a charlen structure. */
10242 resolve_charlen (gfc_charlen
*cl
)
10245 bool saved_specification_expr
;
10251 saved_specification_expr
= specification_expr
;
10252 specification_expr
= true;
10254 if (cl
->length_from_typespec
)
10256 if (!gfc_resolve_expr (cl
->length
))
10258 specification_expr
= saved_specification_expr
;
10262 if (!gfc_simplify_expr (cl
->length
, 0))
10264 specification_expr
= saved_specification_expr
;
10271 if (!resolve_index_expr (cl
->length
))
10273 specification_expr
= saved_specification_expr
;
10278 /* "If the character length parameter value evaluates to a negative
10279 value, the length of character entities declared is zero." */
10280 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10282 if (gfc_option
.warn_surprising
)
10283 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10284 " the length has been set to zero",
10285 &cl
->length
->where
, i
);
10286 gfc_replace_expr (cl
->length
,
10287 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10290 /* Check that the character length is not too large. */
10291 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10292 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10293 && cl
->length
->ts
.type
== BT_INTEGER
10294 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10296 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10297 specification_expr
= saved_specification_expr
;
10301 specification_expr
= saved_specification_expr
;
10306 /* Test for non-constant shape arrays. */
10309 is_non_constant_shape_array (gfc_symbol
*sym
)
10315 not_constant
= false;
10316 if (sym
->as
!= NULL
)
10318 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10319 has not been simplified; parameter array references. Do the
10320 simplification now. */
10321 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10323 e
= sym
->as
->lower
[i
];
10324 if (e
&& (!resolve_index_expr(e
)
10325 || !gfc_is_constant_expr (e
)))
10326 not_constant
= true;
10327 e
= sym
->as
->upper
[i
];
10328 if (e
&& (!resolve_index_expr(e
)
10329 || !gfc_is_constant_expr (e
)))
10330 not_constant
= true;
10333 return not_constant
;
10336 /* Given a symbol and an initialization expression, add code to initialize
10337 the symbol to the function entry. */
10339 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10343 gfc_namespace
*ns
= sym
->ns
;
10345 /* Search for the function namespace if this is a contained
10346 function without an explicit result. */
10347 if (sym
->attr
.function
&& sym
== sym
->result
10348 && sym
->name
!= sym
->ns
->proc_name
->name
)
10350 ns
= ns
->contained
;
10351 for (;ns
; ns
= ns
->sibling
)
10352 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10358 gfc_free_expr (init
);
10362 /* Build an l-value expression for the result. */
10363 lval
= gfc_lval_expr_from_sym (sym
);
10365 /* Add the code at scope entry. */
10366 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10367 init_st
->next
= ns
->code
;
10368 ns
->code
= init_st
;
10370 /* Assign the default initializer to the l-value. */
10371 init_st
->loc
= sym
->declared_at
;
10372 init_st
->expr1
= lval
;
10373 init_st
->expr2
= init
;
10376 /* Assign the default initializer to a derived type variable or result. */
10379 apply_default_init (gfc_symbol
*sym
)
10381 gfc_expr
*init
= NULL
;
10383 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10386 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10387 init
= gfc_default_initializer (&sym
->ts
);
10389 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10392 build_init_assign (sym
, init
);
10393 sym
->attr
.referenced
= 1;
10396 /* Build an initializer for a local integer, real, complex, logical, or
10397 character variable, based on the command line flags finit-local-zero,
10398 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10399 null if the symbol should not have a default initialization. */
10401 build_default_init_expr (gfc_symbol
*sym
)
10404 gfc_expr
*init_expr
;
10407 /* These symbols should never have a default initialization. */
10408 if (sym
->attr
.allocatable
10409 || sym
->attr
.external
10411 || sym
->attr
.pointer
10412 || sym
->attr
.in_equivalence
10413 || sym
->attr
.in_common
10416 || sym
->attr
.cray_pointee
10417 || sym
->attr
.cray_pointer
10421 /* Now we'll try to build an initializer expression. */
10422 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10423 &sym
->declared_at
);
10425 /* We will only initialize integers, reals, complex, logicals, and
10426 characters, and only if the corresponding command-line flags
10427 were set. Otherwise, we free init_expr and return null. */
10428 switch (sym
->ts
.type
)
10431 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10432 mpz_set_si (init_expr
->value
.integer
,
10433 gfc_option
.flag_init_integer_value
);
10436 gfc_free_expr (init_expr
);
10442 switch (gfc_option
.flag_init_real
)
10444 case GFC_INIT_REAL_SNAN
:
10445 init_expr
->is_snan
= 1;
10446 /* Fall through. */
10447 case GFC_INIT_REAL_NAN
:
10448 mpfr_set_nan (init_expr
->value
.real
);
10451 case GFC_INIT_REAL_INF
:
10452 mpfr_set_inf (init_expr
->value
.real
, 1);
10455 case GFC_INIT_REAL_NEG_INF
:
10456 mpfr_set_inf (init_expr
->value
.real
, -1);
10459 case GFC_INIT_REAL_ZERO
:
10460 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10464 gfc_free_expr (init_expr
);
10471 switch (gfc_option
.flag_init_real
)
10473 case GFC_INIT_REAL_SNAN
:
10474 init_expr
->is_snan
= 1;
10475 /* Fall through. */
10476 case GFC_INIT_REAL_NAN
:
10477 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10478 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10481 case GFC_INIT_REAL_INF
:
10482 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10483 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10486 case GFC_INIT_REAL_NEG_INF
:
10487 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10488 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10491 case GFC_INIT_REAL_ZERO
:
10492 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10496 gfc_free_expr (init_expr
);
10503 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10504 init_expr
->value
.logical
= 0;
10505 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10506 init_expr
->value
.logical
= 1;
10509 gfc_free_expr (init_expr
);
10515 /* For characters, the length must be constant in order to
10516 create a default initializer. */
10517 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10518 && sym
->ts
.u
.cl
->length
10519 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10521 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10522 init_expr
->value
.character
.length
= char_len
;
10523 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10524 for (i
= 0; i
< char_len
; i
++)
10525 init_expr
->value
.character
.string
[i
]
10526 = (unsigned char) gfc_option
.flag_init_character_value
;
10530 gfc_free_expr (init_expr
);
10533 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10534 && sym
->ts
.u
.cl
->length
)
10536 gfc_actual_arglist
*arg
;
10537 init_expr
= gfc_get_expr ();
10538 init_expr
->where
= sym
->declared_at
;
10539 init_expr
->ts
= sym
->ts
;
10540 init_expr
->expr_type
= EXPR_FUNCTION
;
10541 init_expr
->value
.function
.isym
=
10542 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10543 init_expr
->value
.function
.name
= "repeat";
10544 arg
= gfc_get_actual_arglist ();
10545 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10547 arg
->expr
->value
.character
.string
[0]
10548 = gfc_option
.flag_init_character_value
;
10549 arg
->next
= gfc_get_actual_arglist ();
10550 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10551 init_expr
->value
.function
.actual
= arg
;
10556 gfc_free_expr (init_expr
);
10562 /* Add an initialization expression to a local variable. */
10564 apply_default_init_local (gfc_symbol
*sym
)
10566 gfc_expr
*init
= NULL
;
10568 /* The symbol should be a variable or a function return value. */
10569 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10570 || (sym
->attr
.function
&& sym
->result
!= sym
))
10573 /* Try to build the initializer expression. If we can't initialize
10574 this symbol, then init will be NULL. */
10575 init
= build_default_init_expr (sym
);
10579 /* For saved variables, we don't want to add an initializer at function
10580 entry, so we just add a static initializer. Note that automatic variables
10581 are stack allocated even with -fno-automatic; we have also to exclude
10582 result variable, which are also nonstatic. */
10583 if (sym
->attr
.save
|| sym
->ns
->save_all
10584 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10585 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10587 /* Don't clobber an existing initializer! */
10588 gcc_assert (sym
->value
== NULL
);
10593 build_init_assign (sym
, init
);
10597 /* Resolution of common features of flavors variable and procedure. */
10600 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10602 gfc_array_spec
*as
;
10604 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10605 as
= CLASS_DATA (sym
)->as
;
10609 /* Constraints on deferred shape variable. */
10610 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10612 bool pointer
, allocatable
, dimension
;
10614 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10616 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10617 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10618 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10622 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10623 allocatable
= sym
->attr
.allocatable
;
10624 dimension
= sym
->attr
.dimension
;
10629 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10631 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10632 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10635 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10636 "'%s' at %L may not be ALLOCATABLE",
10637 sym
->name
, &sym
->declared_at
))
10641 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10643 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10644 "assumed rank", sym
->name
, &sym
->declared_at
);
10650 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10651 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10653 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10654 sym
->name
, &sym
->declared_at
);
10659 /* Constraints on polymorphic variables. */
10660 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10663 if (sym
->attr
.class_ok
10664 && !sym
->attr
.select_type_temporary
10665 && !UNLIMITED_POLY (sym
)
10666 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10668 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10669 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10670 &sym
->declared_at
);
10675 /* Assume that use associated symbols were checked in the module ns.
10676 Class-variables that are associate-names are also something special
10677 and excepted from the test. */
10678 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10680 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10681 "or pointer", sym
->name
, &sym
->declared_at
);
10690 /* Additional checks for symbols with flavor variable and derived
10691 type. To be called from resolve_fl_variable. */
10694 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10696 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10698 /* Check to see if a derived type is blocked from being host
10699 associated by the presence of another class I symbol in the same
10700 namespace. 14.6.1.3 of the standard and the discussion on
10701 comp.lang.fortran. */
10702 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10703 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10706 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10707 if (s
&& s
->attr
.generic
)
10708 s
= gfc_find_dt_in_generic (s
);
10709 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10711 gfc_error ("The type '%s' cannot be host associated at %L "
10712 "because it is blocked by an incompatible object "
10713 "of the same name declared at %L",
10714 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10720 /* 4th constraint in section 11.3: "If an object of a type for which
10721 component-initialization is specified (R429) appears in the
10722 specification-part of a module and does not have the ALLOCATABLE
10723 or POINTER attribute, the object shall have the SAVE attribute."
10725 The check for initializers is performed with
10726 gfc_has_default_initializer because gfc_default_initializer generates
10727 a hidden default for allocatable components. */
10728 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10729 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10730 && !sym
->ns
->save_all
&& !sym
->attr
.save
10731 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10732 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10733 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10734 "'%s' at %L, needed due to the default "
10735 "initialization", sym
->name
, &sym
->declared_at
))
10738 /* Assign default initializer. */
10739 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10740 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10742 sym
->value
= gfc_default_initializer (&sym
->ts
);
10749 /* Resolve symbols with flavor variable. */
10752 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10754 int no_init_flag
, automatic_flag
;
10756 const char *auto_save_msg
;
10757 bool saved_specification_expr
;
10759 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10762 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
10765 /* Set this flag to check that variables are parameters of all entries.
10766 This check is effected by the call to gfc_resolve_expr through
10767 is_non_constant_shape_array. */
10768 saved_specification_expr
= specification_expr
;
10769 specification_expr
= true;
10771 if (sym
->ns
->proc_name
10772 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10773 || sym
->ns
->proc_name
->attr
.is_main_program
)
10774 && !sym
->attr
.use_assoc
10775 && !sym
->attr
.allocatable
10776 && !sym
->attr
.pointer
10777 && is_non_constant_shape_array (sym
))
10779 /* The shape of a main program or module array needs to be
10781 gfc_error ("The module or main program array '%s' at %L must "
10782 "have constant shape", sym
->name
, &sym
->declared_at
);
10783 specification_expr
= saved_specification_expr
;
10787 /* Constraints on deferred type parameter. */
10788 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10790 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10791 "requires either the pointer or allocatable attribute",
10792 sym
->name
, &sym
->declared_at
);
10793 specification_expr
= saved_specification_expr
;
10797 if (sym
->ts
.type
== BT_CHARACTER
)
10799 /* Make sure that character string variables with assumed length are
10800 dummy arguments. */
10801 e
= sym
->ts
.u
.cl
->length
;
10802 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10803 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
10805 gfc_error ("Entity with assumed character length at %L must be a "
10806 "dummy argument or a PARAMETER", &sym
->declared_at
);
10807 specification_expr
= saved_specification_expr
;
10811 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10813 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10814 specification_expr
= saved_specification_expr
;
10818 if (!gfc_is_constant_expr (e
)
10819 && !(e
->expr_type
== EXPR_VARIABLE
10820 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10822 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10823 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10824 || sym
->ns
->proc_name
->attr
.is_main_program
))
10826 gfc_error ("'%s' at %L must have constant character length "
10827 "in this context", sym
->name
, &sym
->declared_at
);
10828 specification_expr
= saved_specification_expr
;
10831 if (sym
->attr
.in_common
)
10833 gfc_error ("COMMON variable '%s' at %L must have constant "
10834 "character length", sym
->name
, &sym
->declared_at
);
10835 specification_expr
= saved_specification_expr
;
10841 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10842 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10844 /* Determine if the symbol may not have an initializer. */
10845 no_init_flag
= automatic_flag
= 0;
10846 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10847 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10849 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10850 && is_non_constant_shape_array (sym
))
10852 no_init_flag
= automatic_flag
= 1;
10854 /* Also, they must not have the SAVE attribute.
10855 SAVE_IMPLICIT is checked below. */
10856 if (sym
->as
&& sym
->attr
.codimension
)
10858 int corank
= sym
->as
->corank
;
10859 sym
->as
->corank
= 0;
10860 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10861 sym
->as
->corank
= corank
;
10863 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10865 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10866 specification_expr
= saved_specification_expr
;
10871 /* Ensure that any initializer is simplified. */
10873 gfc_simplify_expr (sym
->value
, 1);
10875 /* Reject illegal initializers. */
10876 if (!sym
->mark
&& sym
->value
)
10878 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10879 && CLASS_DATA (sym
)->attr
.allocatable
))
10880 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10881 sym
->name
, &sym
->declared_at
);
10882 else if (sym
->attr
.external
)
10883 gfc_error ("External '%s' at %L cannot have an initializer",
10884 sym
->name
, &sym
->declared_at
);
10885 else if (sym
->attr
.dummy
10886 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10887 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10888 sym
->name
, &sym
->declared_at
);
10889 else if (sym
->attr
.intrinsic
)
10890 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10891 sym
->name
, &sym
->declared_at
);
10892 else if (sym
->attr
.result
)
10893 gfc_error ("Function result '%s' at %L cannot have an initializer",
10894 sym
->name
, &sym
->declared_at
);
10895 else if (automatic_flag
)
10896 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10897 sym
->name
, &sym
->declared_at
);
10899 goto no_init_error
;
10900 specification_expr
= saved_specification_expr
;
10905 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10907 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10908 specification_expr
= saved_specification_expr
;
10912 specification_expr
= saved_specification_expr
;
10917 /* Resolve a procedure. */
10920 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10922 gfc_formal_arglist
*arg
;
10924 if (sym
->attr
.function
10925 && !resolve_fl_var_and_proc (sym
, mp_flag
))
10928 if (sym
->ts
.type
== BT_CHARACTER
)
10930 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10932 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10933 && !resolve_charlen (cl
))
10936 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10937 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10939 gfc_error ("Character-valued statement function '%s' at %L must "
10940 "have constant length", sym
->name
, &sym
->declared_at
);
10945 /* Ensure that derived type for are not of a private type. Internal
10946 module procedures are excluded by 2.2.3.3 - i.e., they are not
10947 externally accessible and can access all the objects accessible in
10949 if (!(sym
->ns
->parent
10950 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10951 && gfc_check_symbol_access (sym
))
10953 gfc_interface
*iface
;
10955 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
10958 && arg
->sym
->ts
.type
== BT_DERIVED
10959 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10960 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10961 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
10962 "and cannot be a dummy argument"
10963 " of '%s', which is PUBLIC at %L",
10964 arg
->sym
->name
, sym
->name
,
10965 &sym
->declared_at
))
10967 /* Stop this message from recurring. */
10968 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10973 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10974 PRIVATE to the containing module. */
10975 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10977 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10980 && arg
->sym
->ts
.type
== BT_DERIVED
10981 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10982 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10983 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10984 "PUBLIC interface '%s' at %L "
10985 "takes dummy arguments of '%s' which "
10986 "is PRIVATE", iface
->sym
->name
,
10987 sym
->name
, &iface
->sym
->declared_at
,
10988 gfc_typename(&arg
->sym
->ts
)))
10990 /* Stop this message from recurring. */
10991 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10997 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10998 PRIVATE to the containing module. */
10999 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11001 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11004 && arg
->sym
->ts
.type
== BT_DERIVED
11005 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11006 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11007 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
11008 "PUBLIC interface '%s' at %L takes "
11009 "dummy arguments of '%s' which is "
11010 "PRIVATE", iface
->sym
->name
,
11011 sym
->name
, &iface
->sym
->declared_at
,
11012 gfc_typename(&arg
->sym
->ts
)))
11014 /* Stop this message from recurring. */
11015 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11022 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11023 && !sym
->attr
.proc_pointer
)
11025 gfc_error ("Function '%s' at %L cannot have an initializer",
11026 sym
->name
, &sym
->declared_at
);
11030 /* An external symbol may not have an initializer because it is taken to be
11031 a procedure. Exception: Procedure Pointers. */
11032 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11034 gfc_error ("External object '%s' at %L may not have an initializer",
11035 sym
->name
, &sym
->declared_at
);
11039 /* An elemental function is required to return a scalar 12.7.1 */
11040 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11042 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11043 "result", sym
->name
, &sym
->declared_at
);
11044 /* Reset so that the error only occurs once. */
11045 sym
->attr
.elemental
= 0;
11049 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11050 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11052 gfc_error ("Statement function '%s' at %L may not have pointer or "
11053 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11057 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11058 char-len-param shall not be array-valued, pointer-valued, recursive
11059 or pure. ....snip... A character value of * may only be used in the
11060 following ways: (i) Dummy arg of procedure - dummy associates with
11061 actual length; (ii) To declare a named constant; or (iii) External
11062 function - but length must be declared in calling scoping unit. */
11063 if (sym
->attr
.function
11064 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11065 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11067 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11068 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11070 if (sym
->as
&& sym
->as
->rank
)
11071 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11072 "array-valued", sym
->name
, &sym
->declared_at
);
11074 if (sym
->attr
.pointer
)
11075 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11076 "pointer-valued", sym
->name
, &sym
->declared_at
);
11078 if (sym
->attr
.pure
)
11079 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11080 "pure", sym
->name
, &sym
->declared_at
);
11082 if (sym
->attr
.recursive
)
11083 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11084 "recursive", sym
->name
, &sym
->declared_at
);
11089 /* Appendix B.2 of the standard. Contained functions give an
11090 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11091 character length is an F2003 feature. */
11092 if (!sym
->attr
.contained
11093 && gfc_current_form
!= FORM_FIXED
11094 && !sym
->ts
.deferred
)
11095 gfc_notify_std (GFC_STD_F95_OBS
,
11096 "CHARACTER(*) function '%s' at %L",
11097 sym
->name
, &sym
->declared_at
);
11100 /* F2008, C1218. */
11101 if (sym
->attr
.elemental
)
11103 if (sym
->attr
.proc_pointer
)
11105 gfc_error ("Procedure pointer '%s' at %L shall not be elemental",
11106 sym
->name
, &sym
->declared_at
);
11109 if (sym
->attr
.dummy
)
11111 gfc_error ("Dummy procedure '%s' at %L shall not be elemental",
11112 sym
->name
, &sym
->declared_at
);
11117 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11119 gfc_formal_arglist
*curr_arg
;
11120 int has_non_interop_arg
= 0;
11122 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11123 sym
->common_block
))
11125 /* Clear these to prevent looking at them again if there was an
11127 sym
->attr
.is_bind_c
= 0;
11128 sym
->attr
.is_c_interop
= 0;
11129 sym
->ts
.is_c_interop
= 0;
11133 /* So far, no errors have been found. */
11134 sym
->attr
.is_c_interop
= 1;
11135 sym
->ts
.is_c_interop
= 1;
11138 curr_arg
= gfc_sym_get_dummy_args (sym
);
11139 while (curr_arg
!= NULL
)
11141 /* Skip implicitly typed dummy args here. */
11142 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11143 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11144 /* If something is found to fail, record the fact so we
11145 can mark the symbol for the procedure as not being
11146 BIND(C) to try and prevent multiple errors being
11148 has_non_interop_arg
= 1;
11150 curr_arg
= curr_arg
->next
;
11153 /* See if any of the arguments were not interoperable and if so, clear
11154 the procedure symbol to prevent duplicate error messages. */
11155 if (has_non_interop_arg
!= 0)
11157 sym
->attr
.is_c_interop
= 0;
11158 sym
->ts
.is_c_interop
= 0;
11159 sym
->attr
.is_bind_c
= 0;
11163 if (!sym
->attr
.proc_pointer
)
11165 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11167 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11168 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11171 if (sym
->attr
.intent
)
11173 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11174 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11177 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11179 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11180 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11183 if (sym
->attr
.external
&& sym
->attr
.function
11184 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11185 || sym
->attr
.contained
))
11187 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11188 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11191 if (strcmp ("ppr@", sym
->name
) == 0)
11193 gfc_error ("Procedure pointer result '%s' at %L "
11194 "is missing the pointer attribute",
11195 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11204 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11205 been defined and we now know their defined arguments, check that they fulfill
11206 the requirements of the standard for procedures used as finalizers. */
11209 gfc_resolve_finalizers (gfc_symbol
* derived
)
11211 gfc_finalizer
* list
;
11212 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11213 bool result
= true;
11214 bool seen_scalar
= false;
11216 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11219 /* Walk over the list of finalizer-procedures, check them, and if any one
11220 does not fit in with the standard's definition, print an error and remove
11221 it from the list. */
11222 prev_link
= &derived
->f2k_derived
->finalizers
;
11223 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11225 gfc_formal_arglist
*dummy_args
;
11230 /* Skip this finalizer if we already resolved it. */
11231 if (list
->proc_tree
)
11233 prev_link
= &(list
->next
);
11237 /* Check this exists and is a SUBROUTINE. */
11238 if (!list
->proc_sym
->attr
.subroutine
)
11240 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11241 list
->proc_sym
->name
, &list
->where
);
11245 /* We should have exactly one argument. */
11246 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11247 if (!dummy_args
|| dummy_args
->next
)
11249 gfc_error ("FINAL procedure at %L must have exactly one argument",
11253 arg
= dummy_args
->sym
;
11255 /* This argument must be of our type. */
11256 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11258 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11259 &arg
->declared_at
, derived
->name
);
11263 /* It must neither be a pointer nor allocatable nor optional. */
11264 if (arg
->attr
.pointer
)
11266 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11267 &arg
->declared_at
);
11270 if (arg
->attr
.allocatable
)
11272 gfc_error ("Argument of FINAL procedure at %L must not be"
11273 " ALLOCATABLE", &arg
->declared_at
);
11276 if (arg
->attr
.optional
)
11278 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11279 &arg
->declared_at
);
11283 /* It must not be INTENT(OUT). */
11284 if (arg
->attr
.intent
== INTENT_OUT
)
11286 gfc_error ("Argument of FINAL procedure at %L must not be"
11287 " INTENT(OUT)", &arg
->declared_at
);
11291 /* Warn if the procedure is non-scalar and not assumed shape. */
11292 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11293 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11294 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11295 " shape argument", &arg
->declared_at
);
11297 /* Check that it does not match in kind and rank with a FINAL procedure
11298 defined earlier. To really loop over the *earlier* declarations,
11299 we need to walk the tail of the list as new ones were pushed at the
11301 /* TODO: Handle kind parameters once they are implemented. */
11302 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11303 for (i
= list
->next
; i
; i
= i
->next
)
11305 gfc_formal_arglist
*dummy_args
;
11307 /* Argument list might be empty; that is an error signalled earlier,
11308 but we nevertheless continued resolving. */
11309 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11312 gfc_symbol
* i_arg
= dummy_args
->sym
;
11313 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11314 if (i_rank
== my_rank
)
11316 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11317 " rank (%d) as '%s'",
11318 list
->proc_sym
->name
, &list
->where
, my_rank
,
11319 i
->proc_sym
->name
);
11325 /* Is this the/a scalar finalizer procedure? */
11326 if (!arg
->as
|| arg
->as
->rank
== 0)
11327 seen_scalar
= true;
11329 /* Find the symtree for this procedure. */
11330 gcc_assert (!list
->proc_tree
);
11331 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11333 prev_link
= &list
->next
;
11336 /* Remove wrong nodes immediately from the list so we don't risk any
11337 troubles in the future when they might fail later expectations. */
11341 *prev_link
= list
->next
;
11342 gfc_free_finalizer (i
);
11345 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11346 were nodes in the list, must have been for arrays. It is surely a good
11347 idea to have a scalar version there if there's something to finalize. */
11348 if (gfc_option
.warn_surprising
&& result
&& !seen_scalar
)
11349 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11350 " defined at %L, suggest also scalar one",
11351 derived
->name
, &derived
->declared_at
);
11353 gfc_find_derived_vtab (derived
);
11358 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11361 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11362 const char* generic_name
, locus where
)
11364 gfc_symbol
*sym1
, *sym2
;
11365 const char *pass1
, *pass2
;
11367 gcc_assert (t1
->specific
&& t2
->specific
);
11368 gcc_assert (!t1
->specific
->is_generic
);
11369 gcc_assert (!t2
->specific
->is_generic
);
11370 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11372 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11373 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11378 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11379 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11380 || sym1
->attr
.function
!= sym2
->attr
.function
)
11382 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11383 " GENERIC '%s' at %L",
11384 sym1
->name
, sym2
->name
, generic_name
, &where
);
11388 /* Compare the interfaces. */
11389 if (t1
->specific
->nopass
)
11391 else if (t1
->specific
->pass_arg
)
11392 pass1
= t1
->specific
->pass_arg
;
11394 pass1
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11395 if (t2
->specific
->nopass
)
11397 else if (t2
->specific
->pass_arg
)
11398 pass2
= t2
->specific
->pass_arg
;
11400 pass2
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11401 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11402 NULL
, 0, pass1
, pass2
))
11404 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11405 sym1
->name
, sym2
->name
, generic_name
, &where
);
11413 /* Worker function for resolving a generic procedure binding; this is used to
11414 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11416 The difference between those cases is finding possible inherited bindings
11417 that are overridden, as one has to look for them in tb_sym_root,
11418 tb_uop_root or tb_op, respectively. Thus the caller must already find
11419 the super-type and set p->overridden correctly. */
11422 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11423 gfc_typebound_proc
* p
, const char* name
)
11425 gfc_tbp_generic
* target
;
11426 gfc_symtree
* first_target
;
11427 gfc_symtree
* inherited
;
11429 gcc_assert (p
&& p
->is_generic
);
11431 /* Try to find the specific bindings for the symtrees in our target-list. */
11432 gcc_assert (p
->u
.generic
);
11433 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11434 if (!target
->specific
)
11436 gfc_typebound_proc
* overridden_tbp
;
11437 gfc_tbp_generic
* g
;
11438 const char* target_name
;
11440 target_name
= target
->specific_st
->name
;
11442 /* Defined for this type directly. */
11443 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11445 target
->specific
= target
->specific_st
->n
.tb
;
11446 goto specific_found
;
11449 /* Look for an inherited specific binding. */
11452 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11457 gcc_assert (inherited
->n
.tb
);
11458 target
->specific
= inherited
->n
.tb
;
11459 goto specific_found
;
11463 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11464 " at %L", target_name
, name
, &p
->where
);
11467 /* Once we've found the specific binding, check it is not ambiguous with
11468 other specifics already found or inherited for the same GENERIC. */
11470 gcc_assert (target
->specific
);
11472 /* This must really be a specific binding! */
11473 if (target
->specific
->is_generic
)
11475 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11476 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11480 /* Check those already resolved on this type directly. */
11481 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11482 if (g
!= target
&& g
->specific
11483 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11486 /* Check for ambiguity with inherited specific targets. */
11487 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11488 overridden_tbp
= overridden_tbp
->overridden
)
11489 if (overridden_tbp
->is_generic
)
11491 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11493 gcc_assert (g
->specific
);
11494 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11500 /* If we attempt to "overwrite" a specific binding, this is an error. */
11501 if (p
->overridden
&& !p
->overridden
->is_generic
)
11503 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11504 " the same name", name
, &p
->where
);
11508 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11509 all must have the same attributes here. */
11510 first_target
= p
->u
.generic
->specific
->u
.specific
;
11511 gcc_assert (first_target
);
11512 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11513 p
->function
= first_target
->n
.sym
->attr
.function
;
11519 /* Resolve a GENERIC procedure binding for a derived type. */
11522 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11524 gfc_symbol
* super_type
;
11526 /* Find the overridden binding if any. */
11527 st
->n
.tb
->overridden
= NULL
;
11528 super_type
= gfc_get_derived_super_type (derived
);
11531 gfc_symtree
* overridden
;
11532 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11535 if (overridden
&& overridden
->n
.tb
)
11536 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11539 /* Resolve using worker function. */
11540 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11544 /* Retrieve the target-procedure of an operator binding and do some checks in
11545 common for intrinsic and user-defined type-bound operators. */
11548 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11550 gfc_symbol
* target_proc
;
11552 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11553 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11554 gcc_assert (target_proc
);
11556 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11557 if (target
->specific
->nopass
)
11559 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11563 return target_proc
;
11567 /* Resolve a type-bound intrinsic operator. */
11570 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11571 gfc_typebound_proc
* p
)
11573 gfc_symbol
* super_type
;
11574 gfc_tbp_generic
* target
;
11576 /* If there's already an error here, do nothing (but don't fail again). */
11580 /* Operators should always be GENERIC bindings. */
11581 gcc_assert (p
->is_generic
);
11583 /* Look for an overridden binding. */
11584 super_type
= gfc_get_derived_super_type (derived
);
11585 if (super_type
&& super_type
->f2k_derived
)
11586 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11589 p
->overridden
= NULL
;
11591 /* Resolve general GENERIC properties using worker function. */
11592 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11595 /* Check the targets to be procedures of correct interface. */
11596 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11598 gfc_symbol
* target_proc
;
11600 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11604 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11607 /* Add target to non-typebound operator list. */
11608 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11609 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11611 gfc_interface
*head
, *intr
;
11612 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11614 head
= derived
->ns
->op
[op
];
11615 intr
= gfc_get_interface ();
11616 intr
->sym
= target_proc
;
11617 intr
->where
= p
->where
;
11619 derived
->ns
->op
[op
] = intr
;
11631 /* Resolve a type-bound user operator (tree-walker callback). */
11633 static gfc_symbol
* resolve_bindings_derived
;
11634 static bool resolve_bindings_result
;
11636 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11639 resolve_typebound_user_op (gfc_symtree
* stree
)
11641 gfc_symbol
* super_type
;
11642 gfc_tbp_generic
* target
;
11644 gcc_assert (stree
&& stree
->n
.tb
);
11646 if (stree
->n
.tb
->error
)
11649 /* Operators should always be GENERIC bindings. */
11650 gcc_assert (stree
->n
.tb
->is_generic
);
11652 /* Find overridden procedure, if any. */
11653 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11654 if (super_type
&& super_type
->f2k_derived
)
11656 gfc_symtree
* overridden
;
11657 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11658 stree
->name
, true, NULL
);
11660 if (overridden
&& overridden
->n
.tb
)
11661 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11664 stree
->n
.tb
->overridden
= NULL
;
11666 /* Resolve basically using worker function. */
11667 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11670 /* Check the targets to be functions of correct interface. */
11671 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11673 gfc_symbol
* target_proc
;
11675 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11679 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11686 resolve_bindings_result
= false;
11687 stree
->n
.tb
->error
= 1;
11691 /* Resolve the type-bound procedures for a derived type. */
11694 resolve_typebound_procedure (gfc_symtree
* stree
)
11698 gfc_symbol
* me_arg
;
11699 gfc_symbol
* super_type
;
11700 gfc_component
* comp
;
11702 gcc_assert (stree
);
11704 /* Undefined specific symbol from GENERIC target definition. */
11708 if (stree
->n
.tb
->error
)
11711 /* If this is a GENERIC binding, use that routine. */
11712 if (stree
->n
.tb
->is_generic
)
11714 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11719 /* Get the target-procedure to check it. */
11720 gcc_assert (!stree
->n
.tb
->is_generic
);
11721 gcc_assert (stree
->n
.tb
->u
.specific
);
11722 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11723 where
= stree
->n
.tb
->where
;
11725 /* Default access should already be resolved from the parser. */
11726 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11728 if (stree
->n
.tb
->deferred
)
11730 if (!check_proc_interface (proc
, &where
))
11735 /* Check for F08:C465. */
11736 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11737 || (proc
->attr
.proc
!= PROC_MODULE
11738 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11739 || proc
->attr
.abstract
)
11741 gfc_error ("'%s' must be a module procedure or an external procedure with"
11742 " an explicit interface at %L", proc
->name
, &where
);
11747 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11748 stree
->n
.tb
->function
= proc
->attr
.function
;
11750 /* Find the super-type of the current derived type. We could do this once and
11751 store in a global if speed is needed, but as long as not I believe this is
11752 more readable and clearer. */
11753 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11755 /* If PASS, resolve and check arguments if not already resolved / loaded
11756 from a .mod file. */
11757 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11759 gfc_formal_arglist
*dummy_args
;
11761 dummy_args
= gfc_sym_get_dummy_args (proc
);
11762 if (stree
->n
.tb
->pass_arg
)
11764 gfc_formal_arglist
*i
;
11766 /* If an explicit passing argument name is given, walk the arg-list
11767 and look for it. */
11770 stree
->n
.tb
->pass_arg_num
= 1;
11771 for (i
= dummy_args
; i
; i
= i
->next
)
11773 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11778 ++stree
->n
.tb
->pass_arg_num
;
11783 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11785 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11786 stree
->n
.tb
->pass_arg
);
11792 /* Otherwise, take the first one; there should in fact be at least
11794 stree
->n
.tb
->pass_arg_num
= 1;
11797 gfc_error ("Procedure '%s' with PASS at %L must have at"
11798 " least one argument", proc
->name
, &where
);
11801 me_arg
= dummy_args
->sym
;
11804 /* Now check that the argument-type matches and the passed-object
11805 dummy argument is generally fine. */
11807 gcc_assert (me_arg
);
11809 if (me_arg
->ts
.type
!= BT_CLASS
)
11811 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11812 " at %L", proc
->name
, &where
);
11816 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11817 != resolve_bindings_derived
)
11819 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11820 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11821 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11825 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11826 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11828 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11829 " scalar", proc
->name
, &where
);
11832 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11834 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11835 " be ALLOCATABLE", proc
->name
, &where
);
11838 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11840 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11841 " be POINTER", proc
->name
, &where
);
11846 /* If we are extending some type, check that we don't override a procedure
11847 flagged NON_OVERRIDABLE. */
11848 stree
->n
.tb
->overridden
= NULL
;
11851 gfc_symtree
* overridden
;
11852 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11853 stree
->name
, true, NULL
);
11857 if (overridden
->n
.tb
)
11858 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11860 if (!gfc_check_typebound_override (stree
, overridden
))
11865 /* See if there's a name collision with a component directly in this type. */
11866 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11867 if (!strcmp (comp
->name
, stree
->name
))
11869 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11871 stree
->name
, &where
, resolve_bindings_derived
->name
);
11875 /* Try to find a name collision with an inherited component. */
11876 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11878 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11879 " component of '%s'",
11880 stree
->name
, &where
, resolve_bindings_derived
->name
);
11884 stree
->n
.tb
->error
= 0;
11888 resolve_bindings_result
= false;
11889 stree
->n
.tb
->error
= 1;
11894 resolve_typebound_procedures (gfc_symbol
* derived
)
11897 gfc_symbol
* super_type
;
11899 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11902 super_type
= gfc_get_derived_super_type (derived
);
11904 resolve_symbol (super_type
);
11906 resolve_bindings_derived
= derived
;
11907 resolve_bindings_result
= true;
11909 /* Make sure the vtab has been generated. */
11910 gfc_find_derived_vtab (derived
);
11912 if (derived
->f2k_derived
->tb_sym_root
)
11913 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11914 &resolve_typebound_procedure
);
11916 if (derived
->f2k_derived
->tb_uop_root
)
11917 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11918 &resolve_typebound_user_op
);
11920 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11922 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11923 if (p
&& !resolve_typebound_intrinsic_op (derived
,
11924 (gfc_intrinsic_op
)op
, p
))
11925 resolve_bindings_result
= false;
11928 return resolve_bindings_result
;
11932 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11933 to give all identical derived types the same backend_decl. */
11935 add_dt_to_dt_list (gfc_symbol
*derived
)
11937 gfc_dt_list
*dt_list
;
11939 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11940 if (derived
== dt_list
->derived
)
11943 dt_list
= gfc_get_dt_list ();
11944 dt_list
->next
= gfc_derived_types
;
11945 dt_list
->derived
= derived
;
11946 gfc_derived_types
= dt_list
;
11950 /* Ensure that a derived-type is really not abstract, meaning that every
11951 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11954 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11959 if (!ensure_not_abstract_walker (sub
, st
->left
))
11961 if (!ensure_not_abstract_walker (sub
, st
->right
))
11964 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11966 gfc_symtree
* overriding
;
11967 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11970 gcc_assert (overriding
->n
.tb
);
11971 if (overriding
->n
.tb
->deferred
)
11973 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11974 " '%s' is DEFERRED and not overridden",
11975 sub
->name
, &sub
->declared_at
, st
->name
);
11984 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11986 /* The algorithm used here is to recursively travel up the ancestry of sub
11987 and for each ancestor-type, check all bindings. If any of them is
11988 DEFERRED, look it up starting from sub and see if the found (overriding)
11989 binding is not DEFERRED.
11990 This is not the most efficient way to do this, but it should be ok and is
11991 clearer than something sophisticated. */
11993 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11995 if (!ancestor
->attr
.abstract
)
11998 /* Walk bindings of this ancestor. */
11999 if (ancestor
->f2k_derived
)
12002 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12007 /* Find next ancestor type and recurse on it. */
12008 ancestor
= gfc_get_derived_super_type (ancestor
);
12010 return ensure_not_abstract (sub
, ancestor
);
12016 /* This check for typebound defined assignments is done recursively
12017 since the order in which derived types are resolved is not always in
12018 order of the declarations. */
12021 check_defined_assignments (gfc_symbol
*derived
)
12025 for (c
= derived
->components
; c
; c
= c
->next
)
12027 if (c
->ts
.type
!= BT_DERIVED
12029 || c
->attr
.allocatable
12030 || c
->attr
.proc_pointer_comp
12031 || c
->attr
.class_pointer
12032 || c
->attr
.proc_pointer
)
12035 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12036 || (c
->ts
.u
.derived
->f2k_derived
12037 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12039 derived
->attr
.defined_assign_comp
= 1;
12043 check_defined_assignments (c
->ts
.u
.derived
);
12044 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12046 derived
->attr
.defined_assign_comp
= 1;
12053 /* Resolve the components of a derived type. This does not have to wait until
12054 resolution stage, but can be done as soon as the dt declaration has been
12058 resolve_fl_derived0 (gfc_symbol
*sym
)
12060 gfc_symbol
* super_type
;
12063 if (sym
->attr
.unlimited_polymorphic
)
12066 super_type
= gfc_get_derived_super_type (sym
);
12069 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12071 gfc_error ("As extending type '%s' at %L has a coarray component, "
12072 "parent type '%s' shall also have one", sym
->name
,
12073 &sym
->declared_at
, super_type
->name
);
12077 /* Ensure the extended type gets resolved before we do. */
12078 if (super_type
&& !resolve_fl_derived0 (super_type
))
12081 /* An ABSTRACT type must be extensible. */
12082 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12084 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12085 sym
->name
, &sym
->declared_at
);
12089 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12092 for ( ; c
!= NULL
; c
= c
->next
)
12094 if (c
->attr
.artificial
)
12097 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12098 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
12100 gfc_error ("Deferred-length character component '%s' at %L is not "
12101 "yet supported", c
->name
, &c
->loc
);
12106 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12107 && c
->attr
.codimension
12108 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12110 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12111 "deferred shape", c
->name
, &c
->loc
);
12116 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12117 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12119 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12120 "shall not be a coarray", c
->name
, &c
->loc
);
12125 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12126 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12127 || c
->attr
.allocatable
))
12129 gfc_error ("Component '%s' at %L with coarray component "
12130 "shall be a nonpointer, nonallocatable scalar",
12136 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12138 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12139 "is not an array pointer", c
->name
, &c
->loc
);
12143 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12145 gfc_symbol
*ifc
= c
->ts
.interface
;
12147 if (!sym
->attr
.vtype
12148 && !check_proc_interface (ifc
, &c
->loc
))
12151 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12153 /* Resolve interface and copy attributes. */
12154 if (ifc
->formal
&& !ifc
->formal_ns
)
12155 resolve_symbol (ifc
);
12156 if (ifc
->attr
.intrinsic
)
12157 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12161 c
->ts
= ifc
->result
->ts
;
12162 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12163 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12164 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12165 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12166 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12171 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12172 c
->attr
.pointer
= ifc
->attr
.pointer
;
12173 c
->attr
.dimension
= ifc
->attr
.dimension
;
12174 c
->as
= gfc_copy_array_spec (ifc
->as
);
12175 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12177 c
->ts
.interface
= ifc
;
12178 c
->attr
.function
= ifc
->attr
.function
;
12179 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12181 c
->attr
.pure
= ifc
->attr
.pure
;
12182 c
->attr
.elemental
= ifc
->attr
.elemental
;
12183 c
->attr
.recursive
= ifc
->attr
.recursive
;
12184 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12185 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12186 /* Copy char length. */
12187 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12189 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12190 if (cl
->length
&& !cl
->resolved
12191 && !gfc_resolve_expr (cl
->length
))
12197 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12199 /* Since PPCs are not implicitly typed, a PPC without an explicit
12200 interface must be a subroutine. */
12201 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12204 /* Procedure pointer components: Check PASS arg. */
12205 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12206 && !sym
->attr
.vtype
)
12208 gfc_symbol
* me_arg
;
12210 if (c
->tb
->pass_arg
)
12212 gfc_formal_arglist
* i
;
12214 /* If an explicit passing argument name is given, walk the arg-list
12215 and look for it. */
12218 c
->tb
->pass_arg_num
= 1;
12219 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12221 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12226 c
->tb
->pass_arg_num
++;
12231 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12232 "at %L has no argument '%s'", c
->name
,
12233 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12240 /* Otherwise, take the first one; there should in fact be at least
12242 c
->tb
->pass_arg_num
= 1;
12243 if (!c
->ts
.interface
->formal
)
12245 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12246 "must have at least one argument",
12251 me_arg
= c
->ts
.interface
->formal
->sym
;
12254 /* Now check that the argument-type matches. */
12255 gcc_assert (me_arg
);
12256 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12257 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12258 || (me_arg
->ts
.type
== BT_CLASS
12259 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12261 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12262 " the derived type '%s'", me_arg
->name
, c
->name
,
12263 me_arg
->name
, &c
->loc
, sym
->name
);
12268 /* Check for C453. */
12269 if (me_arg
->attr
.dimension
)
12271 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12272 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12278 if (me_arg
->attr
.pointer
)
12280 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12281 "may not have the POINTER attribute", me_arg
->name
,
12282 c
->name
, me_arg
->name
, &c
->loc
);
12287 if (me_arg
->attr
.allocatable
)
12289 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12290 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12291 me_arg
->name
, &c
->loc
);
12296 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12297 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12298 " at %L", c
->name
, &c
->loc
);
12302 /* Check type-spec if this is not the parent-type component. */
12303 if (((sym
->attr
.is_class
12304 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12305 || c
!= sym
->components
->ts
.u
.derived
->components
))
12306 || (!sym
->attr
.is_class
12307 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12308 && !sym
->attr
.vtype
12309 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12312 /* If this type is an extension, set the accessibility of the parent
12315 && ((sym
->attr
.is_class
12316 && c
== sym
->components
->ts
.u
.derived
->components
)
12317 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12318 && strcmp (super_type
->name
, c
->name
) == 0)
12319 c
->attr
.access
= super_type
->attr
.access
;
12321 /* If this type is an extension, see if this component has the same name
12322 as an inherited type-bound procedure. */
12323 if (super_type
&& !sym
->attr
.is_class
12324 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12326 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12327 " inherited type-bound procedure",
12328 c
->name
, sym
->name
, &c
->loc
);
12332 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12333 && !c
->ts
.deferred
)
12335 if (c
->ts
.u
.cl
->length
== NULL
12336 || (!resolve_charlen(c
->ts
.u
.cl
))
12337 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12339 gfc_error ("Character length of component '%s' needs to "
12340 "be a constant specification expression at %L",
12342 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12347 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12348 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12350 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12351 "length must be a POINTER or ALLOCATABLE",
12352 c
->name
, sym
->name
, &c
->loc
);
12356 if (c
->ts
.type
== BT_DERIVED
12357 && sym
->component_access
!= ACCESS_PRIVATE
12358 && gfc_check_symbol_access (sym
)
12359 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12360 && !c
->ts
.u
.derived
->attr
.use_assoc
12361 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12362 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12363 "PRIVATE type and cannot be a component of "
12364 "'%s', which is PUBLIC at %L", c
->name
,
12365 sym
->name
, &sym
->declared_at
))
12368 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12370 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12371 "type %s", c
->name
, &c
->loc
, sym
->name
);
12375 if (sym
->attr
.sequence
)
12377 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12379 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12380 "not have the SEQUENCE attribute",
12381 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12386 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12387 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12388 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12389 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12390 CLASS_DATA (c
)->ts
.u
.derived
12391 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12393 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12394 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12395 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12397 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12398 "that has not been declared", c
->name
, sym
->name
,
12403 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12404 && CLASS_DATA (c
)->attr
.class_pointer
12405 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12406 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12407 && !UNLIMITED_POLY (c
))
12409 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12410 "that has not been declared", c
->name
, sym
->name
,
12416 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12417 && (!c
->attr
.class_ok
12418 || !(CLASS_DATA (c
)->attr
.class_pointer
12419 || CLASS_DATA (c
)->attr
.allocatable
)))
12421 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12422 "or pointer", c
->name
, &c
->loc
);
12423 /* Prevent a recurrence of the error. */
12424 c
->ts
.type
= BT_UNKNOWN
;
12428 /* Ensure that all the derived type components are put on the
12429 derived type list; even in formal namespaces, where derived type
12430 pointer components might not have been declared. */
12431 if (c
->ts
.type
== BT_DERIVED
12433 && c
->ts
.u
.derived
->components
12435 && sym
!= c
->ts
.u
.derived
)
12436 add_dt_to_dt_list (c
->ts
.u
.derived
);
12438 if (!gfc_resolve_array_spec (c
->as
,
12439 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12440 || c
->attr
.allocatable
)))
12443 if (c
->initializer
&& !sym
->attr
.vtype
12444 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12448 check_defined_assignments (sym
);
12450 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12451 sym
->attr
.defined_assign_comp
12452 = super_type
->attr
.defined_assign_comp
;
12454 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12455 all DEFERRED bindings are overridden. */
12456 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12457 && !sym
->attr
.is_class
12458 && !ensure_not_abstract (sym
, super_type
))
12461 /* Add derived type to the derived type list. */
12462 add_dt_to_dt_list (sym
);
12464 /* Check if the type is finalizable. This is done in order to ensure that the
12465 finalization wrapper is generated early enough. */
12466 gfc_is_finalizable (sym
, NULL
);
12472 /* The following procedure does the full resolution of a derived type,
12473 including resolution of all type-bound procedures (if present). In contrast
12474 to 'resolve_fl_derived0' this can only be done after the module has been
12475 parsed completely. */
12478 resolve_fl_derived (gfc_symbol
*sym
)
12480 gfc_symbol
*gen_dt
= NULL
;
12482 if (sym
->attr
.unlimited_polymorphic
)
12485 if (!sym
->attr
.is_class
)
12486 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12487 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12488 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12489 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12490 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12491 "'%s' at %L being the same name as derived "
12492 "type at %L", sym
->name
,
12493 gen_dt
->generic
->sym
== sym
12494 ? gen_dt
->generic
->next
->sym
->name
12495 : gen_dt
->generic
->sym
->name
,
12496 gen_dt
->generic
->sym
== sym
12497 ? &gen_dt
->generic
->next
->sym
->declared_at
12498 : &gen_dt
->generic
->sym
->declared_at
,
12499 &sym
->declared_at
))
12502 /* Resolve the finalizer procedures. */
12503 if (!gfc_resolve_finalizers (sym
))
12506 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12508 /* Fix up incomplete CLASS symbols. */
12509 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12510 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12512 /* Nothing more to do for unlimited polymorphic entities. */
12513 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12515 else if (vptr
->ts
.u
.derived
== NULL
)
12517 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12519 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12523 if (!resolve_fl_derived0 (sym
))
12526 /* Resolve the type-bound procedures. */
12527 if (!resolve_typebound_procedures (sym
))
12535 resolve_fl_namelist (gfc_symbol
*sym
)
12540 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12542 /* Check again, the check in match only works if NAMELIST comes
12544 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12546 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12547 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12551 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12552 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12553 "with assumed shape in namelist '%s' at %L",
12554 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12557 if (is_non_constant_shape_array (nl
->sym
)
12558 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12559 "with nonconstant shape in namelist '%s' at %L",
12560 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12563 if (nl
->sym
->ts
.type
== BT_CHARACTER
12564 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12565 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12566 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12567 "nonconstant character length in "
12568 "namelist '%s' at %L", nl
->sym
->name
,
12569 sym
->name
, &sym
->declared_at
))
12572 /* FIXME: Once UDDTIO is implemented, the following can be
12574 if (nl
->sym
->ts
.type
== BT_CLASS
)
12576 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12577 "polymorphic and requires a defined input/output "
12578 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12582 if (nl
->sym
->ts
.type
== BT_DERIVED
12583 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12584 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12586 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12587 "namelist '%s' at %L with ALLOCATABLE "
12588 "or POINTER components", nl
->sym
->name
,
12589 sym
->name
, &sym
->declared_at
))
12592 /* FIXME: Once UDDTIO is implemented, the following can be
12594 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12595 "ALLOCATABLE or POINTER components and thus requires "
12596 "a defined input/output procedure", nl
->sym
->name
,
12597 sym
->name
, &sym
->declared_at
);
12602 /* Reject PRIVATE objects in a PUBLIC namelist. */
12603 if (gfc_check_symbol_access (sym
))
12605 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12607 if (!nl
->sym
->attr
.use_assoc
12608 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12609 && !gfc_check_symbol_access (nl
->sym
))
12611 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12612 "cannot be member of PUBLIC namelist '%s' at %L",
12613 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12617 /* Types with private components that came here by USE-association. */
12618 if (nl
->sym
->ts
.type
== BT_DERIVED
12619 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12621 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12622 "components and cannot be member of namelist '%s' at %L",
12623 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12627 /* Types with private components that are defined in the same module. */
12628 if (nl
->sym
->ts
.type
== BT_DERIVED
12629 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12630 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12632 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12633 "cannot be a member of PUBLIC namelist '%s' at %L",
12634 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12641 /* 14.1.2 A module or internal procedure represent local entities
12642 of the same type as a namelist member and so are not allowed. */
12643 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12645 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12648 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12649 if ((nl
->sym
== sym
->ns
->proc_name
)
12651 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12656 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12657 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12659 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12660 "attribute in '%s' at %L", nlsym
->name
,
12661 &sym
->declared_at
);
12671 resolve_fl_parameter (gfc_symbol
*sym
)
12673 /* A parameter array's shape needs to be constant. */
12674 if (sym
->as
!= NULL
12675 && (sym
->as
->type
== AS_DEFERRED
12676 || is_non_constant_shape_array (sym
)))
12678 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12679 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12683 /* Make sure a parameter that has been implicitly typed still
12684 matches the implicit type, since PARAMETER statements can precede
12685 IMPLICIT statements. */
12686 if (sym
->attr
.implicit_type
12687 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12690 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12691 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12695 /* Make sure the types of derived parameters are consistent. This
12696 type checking is deferred until resolution because the type may
12697 refer to a derived type from the host. */
12698 if (sym
->ts
.type
== BT_DERIVED
12699 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12701 gfc_error ("Incompatible derived type in PARAMETER at %L",
12702 &sym
->value
->where
);
12709 /* Do anything necessary to resolve a symbol. Right now, we just
12710 assume that an otherwise unknown symbol is a variable. This sort
12711 of thing commonly happens for symbols in module. */
12714 resolve_symbol (gfc_symbol
*sym
)
12716 int check_constant
, mp_flag
;
12717 gfc_symtree
*symtree
;
12718 gfc_symtree
*this_symtree
;
12721 symbol_attribute class_attr
;
12722 gfc_array_spec
*as
;
12723 bool saved_specification_expr
;
12729 if (sym
->attr
.artificial
)
12732 if (sym
->attr
.unlimited_polymorphic
)
12735 if (sym
->attr
.flavor
== FL_UNKNOWN
12736 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12737 && !sym
->attr
.generic
&& !sym
->attr
.external
12738 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12741 /* If we find that a flavorless symbol is an interface in one of the
12742 parent namespaces, find its symtree in this namespace, free the
12743 symbol and set the symtree to point to the interface symbol. */
12744 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12746 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12747 if (symtree
&& (symtree
->n
.sym
->generic
||
12748 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12749 && sym
->ns
->construct_entities
)))
12751 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12753 gfc_release_symbol (sym
);
12754 symtree
->n
.sym
->refs
++;
12755 this_symtree
->n
.sym
= symtree
->n
.sym
;
12760 /* Otherwise give it a flavor according to such attributes as
12762 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12763 && sym
->attr
.intrinsic
== 0)
12764 sym
->attr
.flavor
= FL_VARIABLE
;
12765 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12767 sym
->attr
.flavor
= FL_PROCEDURE
;
12768 if (sym
->attr
.dimension
)
12769 sym
->attr
.function
= 1;
12773 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12774 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12776 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12777 && !resolve_procedure_interface (sym
))
12780 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12781 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12783 if (sym
->attr
.external
)
12784 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12785 "at %L", &sym
->declared_at
);
12787 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12788 "at %L", &sym
->declared_at
);
12793 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
12796 /* Symbols that are module procedures with results (functions) have
12797 the types and array specification copied for type checking in
12798 procedures that call them, as well as for saving to a module
12799 file. These symbols can't stand the scrutiny that their results
12801 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12803 /* Make sure that the intrinsic is consistent with its internal
12804 representation. This needs to be done before assigning a default
12805 type to avoid spurious warnings. */
12806 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12807 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
12810 /* Resolve associate names. */
12812 resolve_assoc_var (sym
, true);
12814 /* Assign default type to symbols that need one and don't have one. */
12815 if (sym
->ts
.type
== BT_UNKNOWN
)
12817 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12819 gfc_set_default_type (sym
, 1, NULL
);
12822 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12823 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12824 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12825 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12827 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12829 /* The specific case of an external procedure should emit an error
12830 in the case that there is no implicit type. */
12832 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12835 /* Result may be in another namespace. */
12836 resolve_symbol (sym
->result
);
12838 if (!sym
->result
->attr
.proc_pointer
)
12840 sym
->ts
= sym
->result
->ts
;
12841 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12842 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12843 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12844 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12845 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12850 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12852 bool saved_specification_expr
= specification_expr
;
12853 specification_expr
= true;
12854 gfc_resolve_array_spec (sym
->result
->as
, false);
12855 specification_expr
= saved_specification_expr
;
12858 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12860 as
= CLASS_DATA (sym
)->as
;
12861 class_attr
= CLASS_DATA (sym
)->attr
;
12862 class_attr
.pointer
= class_attr
.class_pointer
;
12866 class_attr
= sym
->attr
;
12871 if (sym
->attr
.contiguous
12872 && (!class_attr
.dimension
12873 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12874 && !class_attr
.pointer
)))
12876 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12877 "array pointer or an assumed-shape or assumed-rank array",
12878 sym
->name
, &sym
->declared_at
);
12882 /* Assumed size arrays and assumed shape arrays must be dummy
12883 arguments. Array-spec's of implied-shape should have been resolved to
12884 AS_EXPLICIT already. */
12888 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12889 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12890 || as
->type
== AS_ASSUMED_SHAPE
)
12891 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
12893 if (as
->type
== AS_ASSUMED_SIZE
)
12894 gfc_error ("Assumed size array at %L must be a dummy argument",
12895 &sym
->declared_at
);
12897 gfc_error ("Assumed shape array at %L must be a dummy argument",
12898 &sym
->declared_at
);
12901 /* TS 29113, C535a. */
12902 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
12903 && !sym
->attr
.select_type_temporary
)
12905 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12906 &sym
->declared_at
);
12909 if (as
->type
== AS_ASSUMED_RANK
12910 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12912 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12913 "CODIMENSION attribute", &sym
->declared_at
);
12918 /* Make sure symbols with known intent or optional are really dummy
12919 variable. Because of ENTRY statement, this has to be deferred
12920 until resolution time. */
12922 if (!sym
->attr
.dummy
12923 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12925 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12929 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12931 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12932 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12936 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12938 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12939 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12941 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12942 "attribute must have constant length",
12943 sym
->name
, &sym
->declared_at
);
12947 if (sym
->ts
.is_c_interop
12948 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12950 gfc_error ("C interoperable character dummy variable '%s' at %L "
12951 "with VALUE attribute must have length one",
12952 sym
->name
, &sym
->declared_at
);
12957 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12958 && sym
->ts
.u
.derived
->attr
.generic
)
12960 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12961 if (!sym
->ts
.u
.derived
)
12963 gfc_error ("The derived type '%s' at %L is of type '%s', "
12964 "which has not been defined", sym
->name
,
12965 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12966 sym
->ts
.type
= BT_UNKNOWN
;
12971 /* Use the same constraints as TYPE(*), except for the type check
12972 and that only scalars and assumed-size arrays are permitted. */
12973 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
12975 if (!sym
->attr
.dummy
)
12977 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12978 "a dummy argument", sym
->name
, &sym
->declared_at
);
12982 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
12983 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
12984 && sym
->ts
.type
!= BT_COMPLEX
)
12986 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12987 "of type TYPE(*) or of an numeric intrinsic type",
12988 sym
->name
, &sym
->declared_at
);
12992 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12993 || sym
->attr
.pointer
|| sym
->attr
.value
)
12995 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12996 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
12997 "attribute", sym
->name
, &sym
->declared_at
);
13001 if (sym
->attr
.intent
== INTENT_OUT
)
13003 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13004 "have the INTENT(OUT) attribute",
13005 sym
->name
, &sym
->declared_at
);
13008 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13010 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13011 "either be a scalar or an assumed-size array",
13012 sym
->name
, &sym
->declared_at
);
13016 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13017 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13019 sym
->ts
.type
= BT_ASSUMED
;
13020 sym
->as
= gfc_get_array_spec ();
13021 sym
->as
->type
= AS_ASSUMED_SIZE
;
13023 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13025 else if (sym
->ts
.type
== BT_ASSUMED
)
13027 /* TS 29113, C407a. */
13028 if (!sym
->attr
.dummy
)
13030 gfc_error ("Assumed type of variable %s at %L is only permitted "
13031 "for dummy variables", sym
->name
, &sym
->declared_at
);
13034 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13035 || sym
->attr
.pointer
|| sym
->attr
.value
)
13037 gfc_error ("Assumed-type variable %s at %L may not have the "
13038 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13039 sym
->name
, &sym
->declared_at
);
13042 if (sym
->attr
.intent
== INTENT_OUT
)
13044 gfc_error ("Assumed-type variable %s at %L may not have the "
13045 "INTENT(OUT) attribute",
13046 sym
->name
, &sym
->declared_at
);
13049 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13051 gfc_error ("Assumed-type variable %s at %L shall not be an "
13052 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13057 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13058 do this for something that was implicitly typed because that is handled
13059 in gfc_set_default_type. Handle dummy arguments and procedure
13060 definitions separately. Also, anything that is use associated is not
13061 handled here but instead is handled in the module it is declared in.
13062 Finally, derived type definitions are allowed to be BIND(C) since that
13063 only implies that they're interoperable, and they are checked fully for
13064 interoperability when a variable is declared of that type. */
13065 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13066 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13067 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13071 /* First, make sure the variable is declared at the
13072 module-level scope (J3/04-007, Section 15.3). */
13073 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13074 sym
->attr
.in_common
== 0)
13076 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13077 "is neither a COMMON block nor declared at the "
13078 "module level scope", sym
->name
, &(sym
->declared_at
));
13081 else if (sym
->common_head
!= NULL
)
13083 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13087 /* If type() declaration, we need to verify that the components
13088 of the given type are all C interoperable, etc. */
13089 if (sym
->ts
.type
== BT_DERIVED
&&
13090 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13092 /* Make sure the user marked the derived type as BIND(C). If
13093 not, call the verify routine. This could print an error
13094 for the derived type more than once if multiple variables
13095 of that type are declared. */
13096 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13097 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13101 /* Verify the variable itself as C interoperable if it
13102 is BIND(C). It is not possible for this to succeed if
13103 the verify_bind_c_derived_type failed, so don't have to handle
13104 any error returned by verify_bind_c_derived_type. */
13105 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13106 sym
->common_block
);
13111 /* clear the is_bind_c flag to prevent reporting errors more than
13112 once if something failed. */
13113 sym
->attr
.is_bind_c
= 0;
13118 /* If a derived type symbol has reached this point, without its
13119 type being declared, we have an error. Notice that most
13120 conditions that produce undefined derived types have already
13121 been dealt with. However, the likes of:
13122 implicit type(t) (t) ..... call foo (t) will get us here if
13123 the type is not declared in the scope of the implicit
13124 statement. Change the type to BT_UNKNOWN, both because it is so
13125 and to prevent an ICE. */
13126 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13127 && sym
->ts
.u
.derived
->components
== NULL
13128 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13130 gfc_error ("The derived type '%s' at %L is of type '%s', "
13131 "which has not been defined", sym
->name
,
13132 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13133 sym
->ts
.type
= BT_UNKNOWN
;
13137 /* Make sure that the derived type has been resolved and that the
13138 derived type is visible in the symbol's namespace, if it is a
13139 module function and is not PRIVATE. */
13140 if (sym
->ts
.type
== BT_DERIVED
13141 && sym
->ts
.u
.derived
->attr
.use_assoc
13142 && sym
->ns
->proc_name
13143 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13144 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13147 /* Unless the derived-type declaration is use associated, Fortran 95
13148 does not allow public entries of private derived types.
13149 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13150 161 in 95-006r3. */
13151 if (sym
->ts
.type
== BT_DERIVED
13152 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13153 && !sym
->ts
.u
.derived
->attr
.use_assoc
13154 && gfc_check_symbol_access (sym
)
13155 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13156 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13157 "derived type '%s'",
13158 (sym
->attr
.flavor
== FL_PARAMETER
)
13159 ? "parameter" : "variable",
13160 sym
->name
, &sym
->declared_at
,
13161 sym
->ts
.u
.derived
->name
))
13164 /* F2008, C1302. */
13165 if (sym
->ts
.type
== BT_DERIVED
13166 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13167 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13168 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13169 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13171 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13172 "type LOCK_TYPE must be a coarray", sym
->name
,
13173 &sym
->declared_at
);
13177 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13178 default initialization is defined (5.1.2.4.4). */
13179 if (sym
->ts
.type
== BT_DERIVED
13181 && sym
->attr
.intent
== INTENT_OUT
13183 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13185 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13187 if (c
->initializer
)
13189 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13190 "ASSUMED SIZE and so cannot have a default initializer",
13191 sym
->name
, &sym
->declared_at
);
13198 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13199 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13201 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13202 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13207 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13208 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13209 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13210 || class_attr
.codimension
)
13211 && (sym
->attr
.result
|| sym
->result
== sym
))
13213 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13214 "a coarray component", sym
->name
, &sym
->declared_at
);
13219 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13220 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13222 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13223 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13228 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13229 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13230 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13231 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13232 || class_attr
.allocatable
))
13234 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13235 "nonpointer, nonallocatable scalar, which is not a coarray",
13236 sym
->name
, &sym
->declared_at
);
13240 /* F2008, C526. The function-result case was handled above. */
13241 if (class_attr
.codimension
13242 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13243 || sym
->attr
.select_type_temporary
13244 || sym
->ns
->save_all
13245 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13246 || sym
->ns
->proc_name
->attr
.is_main_program
13247 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13249 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13250 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13254 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13255 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13257 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13258 "deferred shape", sym
->name
, &sym
->declared_at
);
13261 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13262 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13264 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13265 "deferred shape", sym
->name
, &sym
->declared_at
);
13270 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13271 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13272 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13273 || (class_attr
.codimension
&& class_attr
.allocatable
))
13274 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13276 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13277 "allocatable coarray or have coarray components",
13278 sym
->name
, &sym
->declared_at
);
13282 if (class_attr
.codimension
&& sym
->attr
.dummy
13283 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13285 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13286 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13287 sym
->ns
->proc_name
->name
);
13291 if (sym
->ts
.type
== BT_LOGICAL
13292 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13293 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13294 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13297 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13298 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13300 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13301 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13302 "%L with non-C_Bool kind in BIND(C) procedure "
13303 "'%s'", sym
->name
, &sym
->declared_at
,
13304 sym
->ns
->proc_name
->name
))
13306 else if (!gfc_logical_kinds
[i
].c_bool
13307 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13308 "'%s' at %L with non-C_Bool kind in "
13309 "BIND(C) procedure '%s'", sym
->name
,
13311 sym
->attr
.function
? sym
->name
13312 : sym
->ns
->proc_name
->name
))
13316 switch (sym
->attr
.flavor
)
13319 if (!resolve_fl_variable (sym
, mp_flag
))
13324 if (!resolve_fl_procedure (sym
, mp_flag
))
13329 if (!resolve_fl_namelist (sym
))
13334 if (!resolve_fl_parameter (sym
))
13342 /* Resolve array specifier. Check as well some constraints
13343 on COMMON blocks. */
13345 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13347 /* Set the formal_arg_flag so that check_conflict will not throw
13348 an error for host associated variables in the specification
13349 expression for an array_valued function. */
13350 if (sym
->attr
.function
&& sym
->as
)
13351 formal_arg_flag
= 1;
13353 saved_specification_expr
= specification_expr
;
13354 specification_expr
= true;
13355 gfc_resolve_array_spec (sym
->as
, check_constant
);
13356 specification_expr
= saved_specification_expr
;
13358 formal_arg_flag
= 0;
13360 /* Resolve formal namespaces. */
13361 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13362 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13363 gfc_resolve (sym
->formal_ns
);
13365 /* Make sure the formal namespace is present. */
13366 if (sym
->formal
&& !sym
->formal_ns
)
13368 gfc_formal_arglist
*formal
= sym
->formal
;
13369 while (formal
&& !formal
->sym
)
13370 formal
= formal
->next
;
13374 sym
->formal_ns
= formal
->sym
->ns
;
13375 if (sym
->ns
!= formal
->sym
->ns
)
13376 sym
->formal_ns
->refs
++;
13380 /* Check threadprivate restrictions. */
13381 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13382 && (!sym
->attr
.in_common
13383 && sym
->module
== NULL
13384 && (sym
->ns
->proc_name
== NULL
13385 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13386 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13388 /* If we have come this far we can apply default-initializers, as
13389 described in 14.7.5, to those variables that have not already
13390 been assigned one. */
13391 if (sym
->ts
.type
== BT_DERIVED
13393 && !sym
->attr
.allocatable
13394 && !sym
->attr
.alloc_comp
)
13396 symbol_attribute
*a
= &sym
->attr
;
13398 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13399 && !a
->in_common
&& !a
->use_assoc
13400 && (a
->referenced
|| a
->result
)
13401 && !(a
->function
&& sym
!= sym
->result
))
13402 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13403 apply_default_init (sym
);
13406 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13407 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13408 && !CLASS_DATA (sym
)->attr
.class_pointer
13409 && !CLASS_DATA (sym
)->attr
.allocatable
)
13410 apply_default_init (sym
);
13412 /* If this symbol has a type-spec, check it. */
13413 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13414 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13415 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13420 /************* Resolve DATA statements *************/
13424 gfc_data_value
*vnode
;
13430 /* Advance the values structure to point to the next value in the data list. */
13433 next_data_value (void)
13435 while (mpz_cmp_ui (values
.left
, 0) == 0)
13438 if (values
.vnode
->next
== NULL
)
13441 values
.vnode
= values
.vnode
->next
;
13442 mpz_set (values
.left
, values
.vnode
->repeat
);
13450 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13456 ar_type mark
= AR_UNKNOWN
;
13458 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13464 if (!gfc_resolve_expr (var
->expr
))
13468 mpz_init_set_si (offset
, 0);
13471 if (e
->expr_type
!= EXPR_VARIABLE
)
13472 gfc_internal_error ("check_data_variable(): Bad expression");
13474 sym
= e
->symtree
->n
.sym
;
13476 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13478 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13479 sym
->name
, &sym
->declared_at
);
13482 if (e
->ref
== NULL
&& sym
->as
)
13484 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13485 " declaration", sym
->name
, where
);
13489 has_pointer
= sym
->attr
.pointer
;
13491 if (gfc_is_coindexed (e
))
13493 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13498 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13500 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13504 && ref
->type
== REF_ARRAY
13505 && ref
->u
.ar
.type
!= AR_FULL
)
13507 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13508 "be a full array", sym
->name
, where
);
13513 if (e
->rank
== 0 || has_pointer
)
13515 mpz_init_set_ui (size
, 1);
13522 /* Find the array section reference. */
13523 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13525 if (ref
->type
!= REF_ARRAY
)
13527 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13533 /* Set marks according to the reference pattern. */
13534 switch (ref
->u
.ar
.type
)
13542 /* Get the start position of array section. */
13543 gfc_get_section_index (ar
, section_index
, &offset
);
13548 gcc_unreachable ();
13551 if (!gfc_array_size (e
, &size
))
13553 gfc_error ("Nonconstant array section at %L in DATA statement",
13555 mpz_clear (offset
);
13562 while (mpz_cmp_ui (size
, 0) > 0)
13564 if (!next_data_value ())
13566 gfc_error ("DATA statement at %L has more variables than values",
13572 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13576 /* If we have more than one element left in the repeat count,
13577 and we have more than one element left in the target variable,
13578 then create a range assignment. */
13579 /* FIXME: Only done for full arrays for now, since array sections
13581 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13582 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13586 if (mpz_cmp (size
, values
.left
) >= 0)
13588 mpz_init_set (range
, values
.left
);
13589 mpz_sub (size
, size
, values
.left
);
13590 mpz_set_ui (values
.left
, 0);
13594 mpz_init_set (range
, size
);
13595 mpz_sub (values
.left
, values
.left
, size
);
13596 mpz_set_ui (size
, 0);
13599 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13602 mpz_add (offset
, offset
, range
);
13609 /* Assign initial value to symbol. */
13612 mpz_sub_ui (values
.left
, values
.left
, 1);
13613 mpz_sub_ui (size
, size
, 1);
13615 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13620 if (mark
== AR_FULL
)
13621 mpz_add_ui (offset
, offset
, 1);
13623 /* Modify the array section indexes and recalculate the offset
13624 for next element. */
13625 else if (mark
== AR_SECTION
)
13626 gfc_advance_section (section_index
, ar
, &offset
);
13630 if (mark
== AR_SECTION
)
13632 for (i
= 0; i
< ar
->dimen
; i
++)
13633 mpz_clear (section_index
[i
]);
13637 mpz_clear (offset
);
13643 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13645 /* Iterate over a list of elements in a DATA statement. */
13648 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13651 iterator_stack frame
;
13652 gfc_expr
*e
, *start
, *end
, *step
;
13653 bool retval
= true;
13655 mpz_init (frame
.value
);
13658 start
= gfc_copy_expr (var
->iter
.start
);
13659 end
= gfc_copy_expr (var
->iter
.end
);
13660 step
= gfc_copy_expr (var
->iter
.step
);
13662 if (!gfc_simplify_expr (start
, 1)
13663 || start
->expr_type
!= EXPR_CONSTANT
)
13665 gfc_error ("start of implied-do loop at %L could not be "
13666 "simplified to a constant value", &start
->where
);
13670 if (!gfc_simplify_expr (end
, 1)
13671 || end
->expr_type
!= EXPR_CONSTANT
)
13673 gfc_error ("end of implied-do loop at %L could not be "
13674 "simplified to a constant value", &start
->where
);
13678 if (!gfc_simplify_expr (step
, 1)
13679 || step
->expr_type
!= EXPR_CONSTANT
)
13681 gfc_error ("step of implied-do loop at %L could not be "
13682 "simplified to a constant value", &start
->where
);
13687 mpz_set (trip
, end
->value
.integer
);
13688 mpz_sub (trip
, trip
, start
->value
.integer
);
13689 mpz_add (trip
, trip
, step
->value
.integer
);
13691 mpz_div (trip
, trip
, step
->value
.integer
);
13693 mpz_set (frame
.value
, start
->value
.integer
);
13695 frame
.prev
= iter_stack
;
13696 frame
.variable
= var
->iter
.var
->symtree
;
13697 iter_stack
= &frame
;
13699 while (mpz_cmp_ui (trip
, 0) > 0)
13701 if (!traverse_data_var (var
->list
, where
))
13707 e
= gfc_copy_expr (var
->expr
);
13708 if (!gfc_simplify_expr (e
, 1))
13715 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13717 mpz_sub_ui (trip
, trip
, 1);
13721 mpz_clear (frame
.value
);
13724 gfc_free_expr (start
);
13725 gfc_free_expr (end
);
13726 gfc_free_expr (step
);
13728 iter_stack
= frame
.prev
;
13733 /* Type resolve variables in the variable list of a DATA statement. */
13736 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13740 for (; var
; var
= var
->next
)
13742 if (var
->expr
== NULL
)
13743 t
= traverse_data_list (var
, where
);
13745 t
= check_data_variable (var
, where
);
13755 /* Resolve the expressions and iterators associated with a data statement.
13756 This is separate from the assignment checking because data lists should
13757 only be resolved once. */
13760 resolve_data_variables (gfc_data_variable
*d
)
13762 for (; d
; d
= d
->next
)
13764 if (d
->list
== NULL
)
13766 if (!gfc_resolve_expr (d
->expr
))
13771 if (!gfc_resolve_iterator (&d
->iter
, false, true))
13774 if (!resolve_data_variables (d
->list
))
13783 /* Resolve a single DATA statement. We implement this by storing a pointer to
13784 the value list into static variables, and then recursively traversing the
13785 variables list, expanding iterators and such. */
13788 resolve_data (gfc_data
*d
)
13791 if (!resolve_data_variables (d
->var
))
13794 values
.vnode
= d
->value
;
13795 if (d
->value
== NULL
)
13796 mpz_set_ui (values
.left
, 0);
13798 mpz_set (values
.left
, d
->value
->repeat
);
13800 if (!traverse_data_var (d
->var
, &d
->where
))
13803 /* At this point, we better not have any values left. */
13805 if (next_data_value ())
13806 gfc_error ("DATA statement at %L has more values than variables",
13811 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13812 accessed by host or use association, is a dummy argument to a pure function,
13813 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13814 is storage associated with any such variable, shall not be used in the
13815 following contexts: (clients of this function). */
13817 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13818 procedure. Returns zero if assignment is OK, nonzero if there is a
13821 gfc_impure_variable (gfc_symbol
*sym
)
13826 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13829 /* Check if the symbol's ns is inside the pure procedure. */
13830 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13834 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13838 proc
= sym
->ns
->proc_name
;
13839 if (sym
->attr
.dummy
13840 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13841 || proc
->attr
.function
))
13844 /* TODO: Sort out what can be storage associated, if anything, and include
13845 it here. In principle equivalences should be scanned but it does not
13846 seem to be possible to storage associate an impure variable this way. */
13851 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13852 current namespace is inside a pure procedure. */
13855 gfc_pure (gfc_symbol
*sym
)
13857 symbol_attribute attr
;
13862 /* Check if the current namespace or one of its parents
13863 belongs to a pure procedure. */
13864 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13866 sym
= ns
->proc_name
;
13870 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13878 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13882 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13883 checks if the current namespace is implicitly pure. Note that this
13884 function returns false for a PURE procedure. */
13887 gfc_implicit_pure (gfc_symbol
*sym
)
13893 /* Check if the current procedure is implicit_pure. Walk up
13894 the procedure list until we find a procedure. */
13895 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13897 sym
= ns
->proc_name
;
13901 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13906 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13907 && !sym
->attr
.pure
;
13911 /* Test whether the current procedure is elemental or not. */
13914 gfc_elemental (gfc_symbol
*sym
)
13916 symbol_attribute attr
;
13919 sym
= gfc_current_ns
->proc_name
;
13924 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13928 /* Warn about unused labels. */
13931 warn_unused_fortran_label (gfc_st_label
*label
)
13936 warn_unused_fortran_label (label
->left
);
13938 if (label
->defined
== ST_LABEL_UNKNOWN
)
13941 switch (label
->referenced
)
13943 case ST_LABEL_UNKNOWN
:
13944 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13948 case ST_LABEL_BAD_TARGET
:
13949 gfc_warning ("Label %d at %L defined but cannot be used",
13950 label
->value
, &label
->where
);
13957 warn_unused_fortran_label (label
->right
);
13961 /* Returns the sequence type of a symbol or sequence. */
13964 sequence_type (gfc_typespec ts
)
13973 if (ts
.u
.derived
->components
== NULL
)
13974 return SEQ_NONDEFAULT
;
13976 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13977 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13978 if (sequence_type (c
->ts
) != result
)
13984 if (ts
.kind
!= gfc_default_character_kind
)
13985 return SEQ_NONDEFAULT
;
13987 return SEQ_CHARACTER
;
13990 if (ts
.kind
!= gfc_default_integer_kind
)
13991 return SEQ_NONDEFAULT
;
13993 return SEQ_NUMERIC
;
13996 if (!(ts
.kind
== gfc_default_real_kind
13997 || ts
.kind
== gfc_default_double_kind
))
13998 return SEQ_NONDEFAULT
;
14000 return SEQ_NUMERIC
;
14003 if (ts
.kind
!= gfc_default_complex_kind
)
14004 return SEQ_NONDEFAULT
;
14006 return SEQ_NUMERIC
;
14009 if (ts
.kind
!= gfc_default_logical_kind
)
14010 return SEQ_NONDEFAULT
;
14012 return SEQ_NUMERIC
;
14015 return SEQ_NONDEFAULT
;
14020 /* Resolve derived type EQUIVALENCE object. */
14023 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14025 gfc_component
*c
= derived
->components
;
14030 /* Shall not be an object of nonsequence derived type. */
14031 if (!derived
->attr
.sequence
)
14033 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14034 "attribute to be an EQUIVALENCE object", sym
->name
,
14039 /* Shall not have allocatable components. */
14040 if (derived
->attr
.alloc_comp
)
14042 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14043 "components to be an EQUIVALENCE object",sym
->name
,
14048 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14050 gfc_error ("Derived type variable '%s' at %L with default "
14051 "initialization cannot be in EQUIVALENCE with a variable "
14052 "in COMMON", sym
->name
, &e
->where
);
14056 for (; c
; c
= c
->next
)
14058 if (c
->ts
.type
== BT_DERIVED
14059 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14062 /* Shall not be an object of sequence derived type containing a pointer
14063 in the structure. */
14064 if (c
->attr
.pointer
)
14066 gfc_error ("Derived type variable '%s' at %L with pointer "
14067 "component(s) cannot be an EQUIVALENCE object",
14068 sym
->name
, &e
->where
);
14076 /* Resolve equivalence object.
14077 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14078 an allocatable array, an object of nonsequence derived type, an object of
14079 sequence derived type containing a pointer at any level of component
14080 selection, an automatic object, a function name, an entry name, a result
14081 name, a named constant, a structure component, or a subobject of any of
14082 the preceding objects. A substring shall not have length zero. A
14083 derived type shall not have components with default initialization nor
14084 shall two objects of an equivalence group be initialized.
14085 Either all or none of the objects shall have an protected attribute.
14086 The simple constraints are done in symbol.c(check_conflict) and the rest
14087 are implemented here. */
14090 resolve_equivalence (gfc_equiv
*eq
)
14093 gfc_symbol
*first_sym
;
14096 locus
*last_where
= NULL
;
14097 seq_type eq_type
, last_eq_type
;
14098 gfc_typespec
*last_ts
;
14099 int object
, cnt_protected
;
14102 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14104 first_sym
= eq
->expr
->symtree
->n
.sym
;
14108 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14112 e
->ts
= e
->symtree
->n
.sym
->ts
;
14113 /* match_varspec might not know yet if it is seeing
14114 array reference or substring reference, as it doesn't
14116 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14118 gfc_ref
*ref
= e
->ref
;
14119 sym
= e
->symtree
->n
.sym
;
14121 if (sym
->attr
.dimension
)
14123 ref
->u
.ar
.as
= sym
->as
;
14127 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14128 if (e
->ts
.type
== BT_CHARACTER
14130 && ref
->type
== REF_ARRAY
14131 && ref
->u
.ar
.dimen
== 1
14132 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14133 && ref
->u
.ar
.stride
[0] == NULL
)
14135 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14136 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14139 /* Optimize away the (:) reference. */
14140 if (start
== NULL
&& end
== NULL
)
14143 e
->ref
= ref
->next
;
14145 e
->ref
->next
= ref
->next
;
14150 ref
->type
= REF_SUBSTRING
;
14152 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14154 ref
->u
.ss
.start
= start
;
14155 if (end
== NULL
&& e
->ts
.u
.cl
)
14156 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14157 ref
->u
.ss
.end
= end
;
14158 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14165 /* Any further ref is an error. */
14168 gcc_assert (ref
->type
== REF_ARRAY
);
14169 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14175 if (!gfc_resolve_expr (e
))
14178 sym
= e
->symtree
->n
.sym
;
14180 if (sym
->attr
.is_protected
)
14182 if (cnt_protected
> 0 && cnt_protected
!= object
)
14184 gfc_error ("Either all or none of the objects in the "
14185 "EQUIVALENCE set at %L shall have the "
14186 "PROTECTED attribute",
14191 /* Shall not equivalence common block variables in a PURE procedure. */
14192 if (sym
->ns
->proc_name
14193 && sym
->ns
->proc_name
->attr
.pure
14194 && sym
->attr
.in_common
)
14196 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14197 "object in the pure procedure '%s'",
14198 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14202 /* Shall not be a named constant. */
14203 if (e
->expr_type
== EXPR_CONSTANT
)
14205 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14206 "object", sym
->name
, &e
->where
);
14210 if (e
->ts
.type
== BT_DERIVED
14211 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14214 /* Check that the types correspond correctly:
14216 A numeric sequence structure may be equivalenced to another sequence
14217 structure, an object of default integer type, default real type, double
14218 precision real type, default logical type such that components of the
14219 structure ultimately only become associated to objects of the same
14220 kind. A character sequence structure may be equivalenced to an object
14221 of default character kind or another character sequence structure.
14222 Other objects may be equivalenced only to objects of the same type and
14223 kind parameters. */
14225 /* Identical types are unconditionally OK. */
14226 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14227 goto identical_types
;
14229 last_eq_type
= sequence_type (*last_ts
);
14230 eq_type
= sequence_type (sym
->ts
);
14232 /* Since the pair of objects is not of the same type, mixed or
14233 non-default sequences can be rejected. */
14235 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14236 "statement at %L with different type objects";
14238 && last_eq_type
== SEQ_MIXED
14239 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14240 || (eq_type
== SEQ_MIXED
14241 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14244 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14245 "statement at %L with objects of different type";
14247 && last_eq_type
== SEQ_NONDEFAULT
14248 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14249 || (eq_type
== SEQ_NONDEFAULT
14250 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14253 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14254 "EQUIVALENCE statement at %L";
14255 if (last_eq_type
== SEQ_CHARACTER
14256 && eq_type
!= SEQ_CHARACTER
14257 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14260 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14261 "EQUIVALENCE statement at %L";
14262 if (last_eq_type
== SEQ_NUMERIC
14263 && eq_type
!= SEQ_NUMERIC
14264 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14269 last_where
= &e
->where
;
14274 /* Shall not be an automatic array. */
14275 if (e
->ref
->type
== REF_ARRAY
14276 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14278 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14279 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14286 /* Shall not be a structure component. */
14287 if (r
->type
== REF_COMPONENT
)
14289 gfc_error ("Structure component '%s' at %L cannot be an "
14290 "EQUIVALENCE object",
14291 r
->u
.c
.component
->name
, &e
->where
);
14295 /* A substring shall not have length zero. */
14296 if (r
->type
== REF_SUBSTRING
)
14298 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14300 gfc_error ("Substring at %L has length zero",
14301 &r
->u
.ss
.start
->where
);
14311 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14314 resolve_fntype (gfc_namespace
*ns
)
14316 gfc_entry_list
*el
;
14319 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14322 /* If there are any entries, ns->proc_name is the entry master
14323 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14325 sym
= ns
->entries
->sym
;
14327 sym
= ns
->proc_name
;
14328 if (sym
->result
== sym
14329 && sym
->ts
.type
== BT_UNKNOWN
14330 && !gfc_set_default_type (sym
, 0, NULL
)
14331 && !sym
->attr
.untyped
)
14333 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14334 sym
->name
, &sym
->declared_at
);
14335 sym
->attr
.untyped
= 1;
14338 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14339 && !sym
->attr
.contained
14340 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14341 && gfc_check_symbol_access (sym
))
14343 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14344 "%L of PRIVATE type '%s'", sym
->name
,
14345 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14349 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14351 if (el
->sym
->result
== el
->sym
14352 && el
->sym
->ts
.type
== BT_UNKNOWN
14353 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14354 && !el
->sym
->attr
.untyped
)
14356 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14357 el
->sym
->name
, &el
->sym
->declared_at
);
14358 el
->sym
->attr
.untyped
= 1;
14364 /* 12.3.2.1.1 Defined operators. */
14367 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14369 gfc_formal_arglist
*formal
;
14371 if (!sym
->attr
.function
)
14373 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14374 sym
->name
, &where
);
14378 if (sym
->ts
.type
== BT_CHARACTER
14379 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14380 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14381 && sym
->result
->ts
.u
.cl
->length
))
14383 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14384 "character length", sym
->name
, &where
);
14388 formal
= gfc_sym_get_dummy_args (sym
);
14389 if (!formal
|| !formal
->sym
)
14391 gfc_error ("User operator procedure '%s' at %L must have at least "
14392 "one argument", sym
->name
, &where
);
14396 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14398 gfc_error ("First argument of operator interface at %L must be "
14399 "INTENT(IN)", &where
);
14403 if (formal
->sym
->attr
.optional
)
14405 gfc_error ("First argument of operator interface at %L cannot be "
14406 "optional", &where
);
14410 formal
= formal
->next
;
14411 if (!formal
|| !formal
->sym
)
14414 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14416 gfc_error ("Second argument of operator interface at %L must be "
14417 "INTENT(IN)", &where
);
14421 if (formal
->sym
->attr
.optional
)
14423 gfc_error ("Second argument of operator interface at %L cannot be "
14424 "optional", &where
);
14430 gfc_error ("Operator interface at %L must have, at most, two "
14431 "arguments", &where
);
14439 gfc_resolve_uops (gfc_symtree
*symtree
)
14441 gfc_interface
*itr
;
14443 if (symtree
== NULL
)
14446 gfc_resolve_uops (symtree
->left
);
14447 gfc_resolve_uops (symtree
->right
);
14449 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14450 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14454 /* Examine all of the expressions associated with a program unit,
14455 assign types to all intermediate expressions, make sure that all
14456 assignments are to compatible types and figure out which names
14457 refer to which functions or subroutines. It doesn't check code
14458 block, which is handled by resolve_code. */
14461 resolve_types (gfc_namespace
*ns
)
14467 gfc_namespace
* old_ns
= gfc_current_ns
;
14469 /* Check that all IMPLICIT types are ok. */
14470 if (!ns
->seen_implicit_none
)
14473 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14474 if (ns
->set_flag
[letter
]
14475 && !resolve_typespec_used (&ns
->default_type
[letter
],
14476 &ns
->implicit_loc
[letter
], NULL
))
14480 gfc_current_ns
= ns
;
14482 resolve_entries (ns
);
14484 resolve_common_vars (ns
->blank_common
.head
, false);
14485 resolve_common_blocks (ns
->common_root
);
14487 resolve_contained_functions (ns
);
14489 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14490 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14491 resolve_formal_arglist (ns
->proc_name
);
14493 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14495 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14496 resolve_charlen (cl
);
14498 gfc_traverse_ns (ns
, resolve_symbol
);
14500 resolve_fntype (ns
);
14502 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14504 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14505 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14506 "also be PURE", n
->proc_name
->name
,
14507 &n
->proc_name
->declared_at
);
14513 gfc_do_concurrent_flag
= 0;
14514 gfc_check_interfaces (ns
);
14516 gfc_traverse_ns (ns
, resolve_values
);
14522 for (d
= ns
->data
; d
; d
= d
->next
)
14526 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14528 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14530 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14531 resolve_equivalence (eq
);
14533 /* Warn about unused labels. */
14534 if (warn_unused_label
)
14535 warn_unused_fortran_label (ns
->st_labels
);
14537 gfc_resolve_uops (ns
->uop_root
);
14539 gfc_current_ns
= old_ns
;
14543 /* Call resolve_code recursively. */
14546 resolve_codes (gfc_namespace
*ns
)
14549 bitmap_obstack old_obstack
;
14551 if (ns
->resolved
== 1)
14554 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14557 gfc_current_ns
= ns
;
14559 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14560 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14563 /* Set to an out of range value. */
14564 current_entry_id
= -1;
14566 old_obstack
= labels_obstack
;
14567 bitmap_obstack_initialize (&labels_obstack
);
14569 resolve_code (ns
->code
, ns
);
14571 bitmap_obstack_release (&labels_obstack
);
14572 labels_obstack
= old_obstack
;
14576 /* This function is called after a complete program unit has been compiled.
14577 Its purpose is to examine all of the expressions associated with a program
14578 unit, assign types to all intermediate expressions, make sure that all
14579 assignments are to compatible types and figure out which names refer to
14580 which functions or subroutines. */
14583 gfc_resolve (gfc_namespace
*ns
)
14585 gfc_namespace
*old_ns
;
14586 code_stack
*old_cs_base
;
14592 old_ns
= gfc_current_ns
;
14593 old_cs_base
= cs_base
;
14595 resolve_types (ns
);
14596 component_assignment_level
= 0;
14597 resolve_codes (ns
);
14599 gfc_current_ns
= old_ns
;
14600 cs_base
= old_cs_base
;
14603 gfc_run_passes (ns
);