1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2014 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
2354 && !gsym
->binding_label
2356 && gsym
->ns
->resolved
!= -1
2357 && gsym
->ns
->proc_name
2358 && not_in_recursive (sym
, gsym
->ns
)
2359 && not_entry_self_reference (sym
, gsym
->ns
))
2361 gfc_symbol
*def_sym
;
2363 /* Resolve the gsymbol namespace if needed. */
2364 if (!gsym
->ns
->resolved
)
2366 gfc_dt_list
*old_dt_list
;
2367 struct gfc_omp_saved_state old_omp_state
;
2369 /* Stash away derived types so that the backend_decls do not
2371 old_dt_list
= gfc_derived_types
;
2372 gfc_derived_types
= NULL
;
2373 /* And stash away openmp state. */
2374 gfc_omp_save_and_clear_state (&old_omp_state
);
2376 gfc_resolve (gsym
->ns
);
2378 /* Store the new derived types with the global namespace. */
2379 if (gfc_derived_types
)
2380 gsym
->ns
->derived_types
= gfc_derived_types
;
2382 /* Restore the derived types of this namespace. */
2383 gfc_derived_types
= old_dt_list
;
2384 /* And openmp state. */
2385 gfc_omp_restore_state (&old_omp_state
);
2388 /* Make sure that translation for the gsymbol occurs before
2389 the procedure currently being resolved. */
2390 ns
= gfc_global_ns_list
;
2391 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2393 if (ns
->sibling
== gsym
->ns
)
2395 ns
->sibling
= gsym
->ns
->sibling
;
2396 gsym
->ns
->sibling
= gfc_global_ns_list
;
2397 gfc_global_ns_list
= gsym
->ns
;
2402 def_sym
= gsym
->ns
->proc_name
;
2404 /* This can happen if a binding name has been specified. */
2405 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2406 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2408 if (def_sym
->attr
.entry_master
)
2410 gfc_entry_list
*entry
;
2411 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2412 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2414 def_sym
= entry
->sym
;
2419 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2421 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2422 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2423 gfc_typename (&def_sym
->ts
));
2427 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2428 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2430 gfc_error ("Explicit interface required for '%s' at %L: %s",
2431 sym
->name
, &sym
->declared_at
, reason
);
2435 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2436 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2437 gfc_errors_to_warnings (1);
2439 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2440 reason
, sizeof(reason
), NULL
, NULL
))
2442 gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
2443 sym
->name
, &sym
->declared_at
, reason
);
2448 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2449 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2450 gfc_errors_to_warnings (1);
2452 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2453 gfc_procedure_use (def_sym
, actual
, where
);
2457 gfc_errors_to_warnings (0);
2459 if (gsym
->type
== GSYM_UNKNOWN
)
2462 gsym
->where
= *where
;
2469 /************* Function resolution *************/
2471 /* Resolve a function call known to be generic.
2472 Section 14.1.2.4.1. */
2475 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2479 if (sym
->attr
.generic
)
2481 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2484 expr
->value
.function
.name
= s
->name
;
2485 expr
->value
.function
.esym
= s
;
2487 if (s
->ts
.type
!= BT_UNKNOWN
)
2489 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2490 expr
->ts
= s
->result
->ts
;
2493 expr
->rank
= s
->as
->rank
;
2494 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2495 expr
->rank
= s
->result
->as
->rank
;
2497 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2502 /* TODO: Need to search for elemental references in generic
2506 if (sym
->attr
.intrinsic
)
2507 return gfc_intrinsic_func_interface (expr
, 0);
2514 resolve_generic_f (gfc_expr
*expr
)
2518 gfc_interface
*intr
= NULL
;
2520 sym
= expr
->symtree
->n
.sym
;
2524 m
= resolve_generic_f0 (expr
, sym
);
2527 else if (m
== MATCH_ERROR
)
2532 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2533 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2536 if (sym
->ns
->parent
== NULL
)
2538 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2542 if (!generic_sym (sym
))
2546 /* Last ditch attempt. See if the reference is to an intrinsic
2547 that possesses a matching interface. 14.1.2.4 */
2548 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2550 gfc_error ("There is no specific function for the generic '%s' "
2551 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2557 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2560 return resolve_structure_cons (expr
, 0);
2563 m
= gfc_intrinsic_func_interface (expr
, 0);
2568 gfc_error ("Generic function '%s' at %L is not consistent with a "
2569 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2576 /* Resolve a function call known to be specific. */
2579 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2583 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2585 if (sym
->attr
.dummy
)
2587 sym
->attr
.proc
= PROC_DUMMY
;
2591 sym
->attr
.proc
= PROC_EXTERNAL
;
2595 if (sym
->attr
.proc
== PROC_MODULE
2596 || sym
->attr
.proc
== PROC_ST_FUNCTION
2597 || sym
->attr
.proc
== PROC_INTERNAL
)
2600 if (sym
->attr
.intrinsic
)
2602 m
= gfc_intrinsic_func_interface (expr
, 1);
2606 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2607 "with an intrinsic", sym
->name
, &expr
->where
);
2615 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2618 expr
->ts
= sym
->result
->ts
;
2621 expr
->value
.function
.name
= sym
->name
;
2622 expr
->value
.function
.esym
= sym
;
2623 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2624 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2625 else if (sym
->as
!= NULL
)
2626 expr
->rank
= sym
->as
->rank
;
2633 resolve_specific_f (gfc_expr
*expr
)
2638 sym
= expr
->symtree
->n
.sym
;
2642 m
= resolve_specific_f0 (sym
, expr
);
2645 if (m
== MATCH_ERROR
)
2648 if (sym
->ns
->parent
== NULL
)
2651 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2657 gfc_error ("Unable to resolve the specific function '%s' at %L",
2658 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2664 /* Resolve a procedure call not known to be generic nor specific. */
2667 resolve_unknown_f (gfc_expr
*expr
)
2672 sym
= expr
->symtree
->n
.sym
;
2674 if (sym
->attr
.dummy
)
2676 sym
->attr
.proc
= PROC_DUMMY
;
2677 expr
->value
.function
.name
= sym
->name
;
2681 /* See if we have an intrinsic function reference. */
2683 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2685 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2690 /* The reference is to an external name. */
2692 sym
->attr
.proc
= PROC_EXTERNAL
;
2693 expr
->value
.function
.name
= sym
->name
;
2694 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2696 if (sym
->as
!= NULL
)
2697 expr
->rank
= sym
->as
->rank
;
2699 /* Type of the expression is either the type of the symbol or the
2700 default type of the symbol. */
2703 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2705 if (sym
->ts
.type
!= BT_UNKNOWN
)
2709 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2711 if (ts
->type
== BT_UNKNOWN
)
2713 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2714 sym
->name
, &expr
->where
);
2725 /* Return true, if the symbol is an external procedure. */
2727 is_external_proc (gfc_symbol
*sym
)
2729 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2730 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2731 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2732 && !sym
->attr
.proc_pointer
2733 && !sym
->attr
.use_assoc
2741 /* Figure out if a function reference is pure or not. Also set the name
2742 of the function for a potential error message. Return nonzero if the
2743 function is PURE, zero if not. */
2745 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2748 pure_function (gfc_expr
*e
, const char **name
)
2754 if (e
->symtree
!= NULL
2755 && e
->symtree
->n
.sym
!= NULL
2756 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2757 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2759 if (e
->value
.function
.esym
)
2761 pure
= gfc_pure (e
->value
.function
.esym
);
2762 *name
= e
->value
.function
.esym
->name
;
2764 else if (e
->value
.function
.isym
)
2766 pure
= e
->value
.function
.isym
->pure
2767 || e
->value
.function
.isym
->elemental
;
2768 *name
= e
->value
.function
.isym
->name
;
2772 /* Implicit functions are not pure. */
2774 *name
= e
->value
.function
.name
;
2782 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2783 int *f ATTRIBUTE_UNUSED
)
2787 /* Don't bother recursing into other statement functions
2788 since they will be checked individually for purity. */
2789 if (e
->expr_type
!= EXPR_FUNCTION
2791 || e
->symtree
->n
.sym
== sym
2792 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2795 return pure_function (e
, &name
) ? false : true;
2800 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2802 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2806 /* Resolve a function call, which means resolving the arguments, then figuring
2807 out which entity the name refers to. */
2810 resolve_function (gfc_expr
*expr
)
2812 gfc_actual_arglist
*arg
;
2817 procedure_type p
= PROC_INTRINSIC
;
2818 bool no_formal_args
;
2822 sym
= expr
->symtree
->n
.sym
;
2824 /* If this is a procedure pointer component, it has already been resolved. */
2825 if (gfc_is_proc_ptr_comp (expr
))
2828 if (sym
&& sym
->attr
.intrinsic
2829 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2832 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2834 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2838 /* If this ia a deferred TBP with an abstract interface (which may
2839 of course be referenced), expr->value.function.esym will be set. */
2840 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2842 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2843 sym
->name
, &expr
->where
);
2847 /* Switch off assumed size checking and do this again for certain kinds
2848 of procedure, once the procedure itself is resolved. */
2849 need_full_assumed_size
++;
2851 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2852 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2854 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2855 inquiry_argument
= true;
2856 no_formal_args
= sym
&& is_external_proc (sym
)
2857 && gfc_sym_get_dummy_args (sym
) == NULL
;
2859 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2862 inquiry_argument
= false;
2866 inquiry_argument
= false;
2868 /* Resume assumed_size checking. */
2869 need_full_assumed_size
--;
2871 /* If the procedure is external, check for usage. */
2872 if (sym
&& is_external_proc (sym
))
2873 resolve_global_procedure (sym
, &expr
->where
,
2874 &expr
->value
.function
.actual
, 0);
2876 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2878 && sym
->ts
.u
.cl
->length
== NULL
2880 && !sym
->ts
.deferred
2881 && expr
->value
.function
.esym
== NULL
2882 && !sym
->attr
.contained
)
2884 /* Internal procedures are taken care of in resolve_contained_fntype. */
2885 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2886 "be used at %L since it is not a dummy argument",
2887 sym
->name
, &expr
->where
);
2891 /* See if function is already resolved. */
2893 if (expr
->value
.function
.name
!= NULL
)
2895 if (expr
->ts
.type
== BT_UNKNOWN
)
2901 /* Apply the rules of section 14.1.2. */
2903 switch (procedure_kind (sym
))
2906 t
= resolve_generic_f (expr
);
2909 case PTYPE_SPECIFIC
:
2910 t
= resolve_specific_f (expr
);
2914 t
= resolve_unknown_f (expr
);
2918 gfc_internal_error ("resolve_function(): bad function type");
2922 /* If the expression is still a function (it might have simplified),
2923 then we check to see if we are calling an elemental function. */
2925 if (expr
->expr_type
!= EXPR_FUNCTION
)
2928 temp
= need_full_assumed_size
;
2929 need_full_assumed_size
= 0;
2931 if (!resolve_elemental_actual (expr
, NULL
))
2934 if (omp_workshare_flag
2935 && expr
->value
.function
.esym
2936 && ! gfc_elemental (expr
->value
.function
.esym
))
2938 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2939 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2944 #define GENERIC_ID expr->value.function.isym->id
2945 else if (expr
->value
.function
.actual
!= NULL
2946 && expr
->value
.function
.isym
!= NULL
2947 && GENERIC_ID
!= GFC_ISYM_LBOUND
2948 && GENERIC_ID
!= GFC_ISYM_LEN
2949 && GENERIC_ID
!= GFC_ISYM_LOC
2950 && GENERIC_ID
!= GFC_ISYM_C_LOC
2951 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2953 /* Array intrinsics must also have the last upper bound of an
2954 assumed size array argument. UBOUND and SIZE have to be
2955 excluded from the check if the second argument is anything
2958 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2960 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2961 && arg
== expr
->value
.function
.actual
2962 && arg
->next
!= NULL
&& arg
->next
->expr
)
2964 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2967 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2970 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2975 if (arg
->expr
!= NULL
2976 && arg
->expr
->rank
> 0
2977 && resolve_assumed_size_actual (arg
->expr
))
2983 need_full_assumed_size
= temp
;
2986 if (!pure_function (expr
, &name
) && name
)
2990 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2991 "FORALL %s", name
, &expr
->where
,
2992 forall_flag
== 2 ? "mask" : "block");
2995 else if (gfc_do_concurrent_flag
)
2997 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2998 "DO CONCURRENT %s", name
, &expr
->where
,
2999 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3002 else if (gfc_pure (NULL
))
3004 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3005 "procedure within a PURE procedure", name
, &expr
->where
);
3009 if (gfc_implicit_pure (NULL
))
3010 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3013 /* Functions without the RECURSIVE attribution are not allowed to
3014 * call themselves. */
3015 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3018 esym
= expr
->value
.function
.esym
;
3020 if (is_illegal_recursion (esym
, gfc_current_ns
))
3022 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3023 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3024 " function '%s' is not RECURSIVE",
3025 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3027 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3028 " is not RECURSIVE", esym
->name
, &expr
->where
);
3034 /* Character lengths of use associated functions may contains references to
3035 symbols not referenced from the current program unit otherwise. Make sure
3036 those symbols are marked as referenced. */
3038 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3039 && expr
->value
.function
.esym
->attr
.use_assoc
)
3041 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3044 /* Make sure that the expression has a typespec that works. */
3045 if (expr
->ts
.type
== BT_UNKNOWN
)
3047 if (expr
->symtree
->n
.sym
->result
3048 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3049 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3050 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3057 /************* Subroutine resolution *************/
3060 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3066 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3067 sym
->name
, &c
->loc
);
3068 else if (gfc_do_concurrent_flag
)
3069 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3070 "PURE", sym
->name
, &c
->loc
);
3071 else if (gfc_pure (NULL
))
3072 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3075 if (gfc_implicit_pure (NULL
))
3076 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3081 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3085 if (sym
->attr
.generic
)
3087 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3090 c
->resolved_sym
= s
;
3091 pure_subroutine (c
, s
);
3095 /* TODO: Need to search for elemental references in generic interface. */
3098 if (sym
->attr
.intrinsic
)
3099 return gfc_intrinsic_sub_interface (c
, 0);
3106 resolve_generic_s (gfc_code
*c
)
3111 sym
= c
->symtree
->n
.sym
;
3115 m
= resolve_generic_s0 (c
, sym
);
3118 else if (m
== MATCH_ERROR
)
3122 if (sym
->ns
->parent
== NULL
)
3124 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3128 if (!generic_sym (sym
))
3132 /* Last ditch attempt. See if the reference is to an intrinsic
3133 that possesses a matching interface. 14.1.2.4 */
3134 sym
= c
->symtree
->n
.sym
;
3136 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3138 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3139 sym
->name
, &c
->loc
);
3143 m
= gfc_intrinsic_sub_interface (c
, 0);
3147 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3148 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3154 /* Resolve a subroutine call known to be specific. */
3157 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3161 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3163 if (sym
->attr
.dummy
)
3165 sym
->attr
.proc
= PROC_DUMMY
;
3169 sym
->attr
.proc
= PROC_EXTERNAL
;
3173 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3176 if (sym
->attr
.intrinsic
)
3178 m
= gfc_intrinsic_sub_interface (c
, 1);
3182 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3183 "with an intrinsic", sym
->name
, &c
->loc
);
3191 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3193 c
->resolved_sym
= sym
;
3194 pure_subroutine (c
, sym
);
3201 resolve_specific_s (gfc_code
*c
)
3206 sym
= c
->symtree
->n
.sym
;
3210 m
= resolve_specific_s0 (c
, sym
);
3213 if (m
== MATCH_ERROR
)
3216 if (sym
->ns
->parent
== NULL
)
3219 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3225 sym
= c
->symtree
->n
.sym
;
3226 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3227 sym
->name
, &c
->loc
);
3233 /* Resolve a subroutine call not known to be generic nor specific. */
3236 resolve_unknown_s (gfc_code
*c
)
3240 sym
= c
->symtree
->n
.sym
;
3242 if (sym
->attr
.dummy
)
3244 sym
->attr
.proc
= PROC_DUMMY
;
3248 /* See if we have an intrinsic function reference. */
3250 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3252 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3257 /* The reference is to an external name. */
3260 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3262 c
->resolved_sym
= sym
;
3264 pure_subroutine (c
, sym
);
3270 /* Resolve a subroutine call. Although it was tempting to use the same code
3271 for functions, subroutines and functions are stored differently and this
3272 makes things awkward. */
3275 resolve_call (gfc_code
*c
)
3278 procedure_type ptype
= PROC_INTRINSIC
;
3279 gfc_symbol
*csym
, *sym
;
3280 bool no_formal_args
;
3282 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3284 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3286 gfc_error ("'%s' at %L has a type, which is not consistent with "
3287 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3291 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3294 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3295 sym
= st
? st
->n
.sym
: NULL
;
3296 if (sym
&& csym
!= sym
3297 && sym
->ns
== gfc_current_ns
3298 && sym
->attr
.flavor
== FL_PROCEDURE
3299 && sym
->attr
.contained
)
3302 if (csym
->attr
.generic
)
3303 c
->symtree
->n
.sym
= sym
;
3306 csym
= c
->symtree
->n
.sym
;
3310 /* If this ia a deferred TBP, c->expr1 will be set. */
3311 if (!c
->expr1
&& csym
)
3313 if (csym
->attr
.abstract
)
3315 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3316 csym
->name
, &c
->loc
);
3320 /* Subroutines without the RECURSIVE attribution are not allowed to
3322 if (is_illegal_recursion (csym
, gfc_current_ns
))
3324 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3325 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3326 "as subroutine '%s' is not RECURSIVE",
3327 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3329 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3330 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3336 /* Switch off assumed size checking and do this again for certain kinds
3337 of procedure, once the procedure itself is resolved. */
3338 need_full_assumed_size
++;
3341 ptype
= csym
->attr
.proc
;
3343 no_formal_args
= csym
&& is_external_proc (csym
)
3344 && gfc_sym_get_dummy_args (csym
) == NULL
;
3345 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3348 /* Resume assumed_size checking. */
3349 need_full_assumed_size
--;
3351 /* If external, check for usage. */
3352 if (csym
&& is_external_proc (csym
))
3353 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3356 if (c
->resolved_sym
== NULL
)
3358 c
->resolved_isym
= NULL
;
3359 switch (procedure_kind (csym
))
3362 t
= resolve_generic_s (c
);
3365 case PTYPE_SPECIFIC
:
3366 t
= resolve_specific_s (c
);
3370 t
= resolve_unknown_s (c
);
3374 gfc_internal_error ("resolve_subroutine(): bad function type");
3378 /* Some checks of elemental subroutine actual arguments. */
3379 if (!resolve_elemental_actual (NULL
, c
))
3386 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3387 op1->shape and op2->shape are non-NULL return true if their shapes
3388 match. If both op1->shape and op2->shape are non-NULL return false
3389 if their shapes do not match. If either op1->shape or op2->shape is
3390 NULL, return true. */
3393 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3400 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3402 for (i
= 0; i
< op1
->rank
; i
++)
3404 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3406 gfc_error ("Shapes for operands at %L and %L are not conformable",
3407 &op1
->where
, &op2
->where
);
3418 /* Resolve an operator expression node. This can involve replacing the
3419 operation with a user defined function call. */
3422 resolve_operator (gfc_expr
*e
)
3424 gfc_expr
*op1
, *op2
;
3426 bool dual_locus_error
;
3429 /* Resolve all subnodes-- give them types. */
3431 switch (e
->value
.op
.op
)
3434 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3437 /* Fall through... */
3440 case INTRINSIC_UPLUS
:
3441 case INTRINSIC_UMINUS
:
3442 case INTRINSIC_PARENTHESES
:
3443 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3448 /* Typecheck the new node. */
3450 op1
= e
->value
.op
.op1
;
3451 op2
= e
->value
.op
.op2
;
3452 dual_locus_error
= false;
3454 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3455 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3457 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3461 switch (e
->value
.op
.op
)
3463 case INTRINSIC_UPLUS
:
3464 case INTRINSIC_UMINUS
:
3465 if (op1
->ts
.type
== BT_INTEGER
3466 || op1
->ts
.type
== BT_REAL
3467 || op1
->ts
.type
== BT_COMPLEX
)
3473 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3474 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3477 case INTRINSIC_PLUS
:
3478 case INTRINSIC_MINUS
:
3479 case INTRINSIC_TIMES
:
3480 case INTRINSIC_DIVIDE
:
3481 case INTRINSIC_POWER
:
3482 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3484 gfc_type_convert_binary (e
, 1);
3489 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3490 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3491 gfc_typename (&op2
->ts
));
3494 case INTRINSIC_CONCAT
:
3495 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3496 && op1
->ts
.kind
== op2
->ts
.kind
)
3498 e
->ts
.type
= BT_CHARACTER
;
3499 e
->ts
.kind
= op1
->ts
.kind
;
3504 _("Operands of string concatenation operator at %%L are %s/%s"),
3505 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3511 case INTRINSIC_NEQV
:
3512 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3514 e
->ts
.type
= BT_LOGICAL
;
3515 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3516 if (op1
->ts
.kind
< e
->ts
.kind
)
3517 gfc_convert_type (op1
, &e
->ts
, 2);
3518 else if (op2
->ts
.kind
< e
->ts
.kind
)
3519 gfc_convert_type (op2
, &e
->ts
, 2);
3523 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3524 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3525 gfc_typename (&op2
->ts
));
3530 if (op1
->ts
.type
== BT_LOGICAL
)
3532 e
->ts
.type
= BT_LOGICAL
;
3533 e
->ts
.kind
= op1
->ts
.kind
;
3537 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3538 gfc_typename (&op1
->ts
));
3542 case INTRINSIC_GT_OS
:
3544 case INTRINSIC_GE_OS
:
3546 case INTRINSIC_LT_OS
:
3548 case INTRINSIC_LE_OS
:
3549 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3551 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3555 /* Fall through... */
3558 case INTRINSIC_EQ_OS
:
3560 case INTRINSIC_NE_OS
:
3561 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3562 && op1
->ts
.kind
== op2
->ts
.kind
)
3564 e
->ts
.type
= BT_LOGICAL
;
3565 e
->ts
.kind
= gfc_default_logical_kind
;
3569 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3571 gfc_type_convert_binary (e
, 1);
3573 e
->ts
.type
= BT_LOGICAL
;
3574 e
->ts
.kind
= gfc_default_logical_kind
;
3576 if (gfc_option
.warn_compare_reals
)
3578 gfc_intrinsic_op op
= e
->value
.op
.op
;
3580 /* Type conversion has made sure that the types of op1 and op2
3581 agree, so it is only necessary to check the first one. */
3582 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3583 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3584 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3588 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3589 msg
= "Equality comparison for %s at %L";
3591 msg
= "Inequality comparison for %s at %L";
3593 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3600 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3602 _("Logicals at %%L must be compared with %s instead of %s"),
3603 (e
->value
.op
.op
== INTRINSIC_EQ
3604 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3605 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3608 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3609 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3610 gfc_typename (&op2
->ts
));
3614 case INTRINSIC_USER
:
3615 if (e
->value
.op
.uop
->op
== NULL
)
3616 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3617 else if (op2
== NULL
)
3618 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3619 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3622 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3623 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3624 gfc_typename (&op2
->ts
));
3625 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3630 case INTRINSIC_PARENTHESES
:
3632 if (e
->ts
.type
== BT_CHARACTER
)
3633 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3637 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3640 /* Deal with arrayness of an operand through an operator. */
3644 switch (e
->value
.op
.op
)
3646 case INTRINSIC_PLUS
:
3647 case INTRINSIC_MINUS
:
3648 case INTRINSIC_TIMES
:
3649 case INTRINSIC_DIVIDE
:
3650 case INTRINSIC_POWER
:
3651 case INTRINSIC_CONCAT
:
3655 case INTRINSIC_NEQV
:
3657 case INTRINSIC_EQ_OS
:
3659 case INTRINSIC_NE_OS
:
3661 case INTRINSIC_GT_OS
:
3663 case INTRINSIC_GE_OS
:
3665 case INTRINSIC_LT_OS
:
3667 case INTRINSIC_LE_OS
:
3669 if (op1
->rank
== 0 && op2
->rank
== 0)
3672 if (op1
->rank
== 0 && op2
->rank
!= 0)
3674 e
->rank
= op2
->rank
;
3676 if (e
->shape
== NULL
)
3677 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3680 if (op1
->rank
!= 0 && op2
->rank
== 0)
3682 e
->rank
= op1
->rank
;
3684 if (e
->shape
== NULL
)
3685 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3688 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3690 if (op1
->rank
== op2
->rank
)
3692 e
->rank
= op1
->rank
;
3693 if (e
->shape
== NULL
)
3695 t
= compare_shapes (op1
, op2
);
3699 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3704 /* Allow higher level expressions to work. */
3707 /* Try user-defined operators, and otherwise throw an error. */
3708 dual_locus_error
= true;
3710 _("Inconsistent ranks for operator at %%L and %%L"));
3717 case INTRINSIC_PARENTHESES
:
3719 case INTRINSIC_UPLUS
:
3720 case INTRINSIC_UMINUS
:
3721 /* Simply copy arrayness attribute */
3722 e
->rank
= op1
->rank
;
3724 if (e
->shape
== NULL
)
3725 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3733 /* Attempt to simplify the expression. */
3736 t
= gfc_simplify_expr (e
, 0);
3737 /* Some calls do not succeed in simplification and return false
3738 even though there is no error; e.g. variable references to
3739 PARAMETER arrays. */
3740 if (!gfc_is_constant_expr (e
))
3748 match m
= gfc_extend_expr (e
);
3751 if (m
== MATCH_ERROR
)
3755 if (dual_locus_error
)
3756 gfc_error (msg
, &op1
->where
, &op2
->where
);
3758 gfc_error (msg
, &e
->where
);
3764 /************** Array resolution subroutines **************/
3767 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3770 /* Compare two integer expressions. */
3773 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3777 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3778 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3781 /* If either of the types isn't INTEGER, we must have
3782 raised an error earlier. */
3784 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3787 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3797 /* Compare an integer expression with an integer. */
3800 compare_bound_int (gfc_expr
*a
, int b
)
3804 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3807 if (a
->ts
.type
!= BT_INTEGER
)
3808 gfc_internal_error ("compare_bound_int(): Bad expression");
3810 i
= mpz_cmp_si (a
->value
.integer
, b
);
3820 /* Compare an integer expression with a mpz_t. */
3823 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3827 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3830 if (a
->ts
.type
!= BT_INTEGER
)
3831 gfc_internal_error ("compare_bound_int(): Bad expression");
3833 i
= mpz_cmp (a
->value
.integer
, b
);
3843 /* Compute the last value of a sequence given by a triplet.
3844 Return 0 if it wasn't able to compute the last value, or if the
3845 sequence if empty, and 1 otherwise. */
3848 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3849 gfc_expr
*stride
, mpz_t last
)
3853 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3854 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3855 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3858 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3859 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3862 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3864 if (compare_bound (start
, end
) == CMP_GT
)
3866 mpz_set (last
, end
->value
.integer
);
3870 if (compare_bound_int (stride
, 0) == CMP_GT
)
3872 /* Stride is positive */
3873 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3878 /* Stride is negative */
3879 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3884 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3885 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3886 mpz_sub (last
, end
->value
.integer
, rem
);
3893 /* Compare a single dimension of an array reference to the array
3897 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3901 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3903 gcc_assert (ar
->stride
[i
] == NULL
);
3904 /* This implies [*] as [*:] and [*:3] are not possible. */
3905 if (ar
->start
[i
] == NULL
)
3907 gcc_assert (ar
->end
[i
] == NULL
);
3912 /* Given start, end and stride values, calculate the minimum and
3913 maximum referenced indexes. */
3915 switch (ar
->dimen_type
[i
])
3918 case DIMEN_THIS_IMAGE
:
3923 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3926 gfc_warning ("Array reference at %L is out of bounds "
3927 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3928 mpz_get_si (ar
->start
[i
]->value
.integer
),
3929 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3931 gfc_warning ("Array reference at %L is out of bounds "
3932 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3933 mpz_get_si (ar
->start
[i
]->value
.integer
),
3934 mpz_get_si (as
->lower
[i
]->value
.integer
),
3938 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3941 gfc_warning ("Array reference at %L is out of bounds "
3942 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3943 mpz_get_si (ar
->start
[i
]->value
.integer
),
3944 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3946 gfc_warning ("Array reference at %L is out of bounds "
3947 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3948 mpz_get_si (ar
->start
[i
]->value
.integer
),
3949 mpz_get_si (as
->upper
[i
]->value
.integer
),
3958 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3959 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3961 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3963 /* Check for zero stride, which is not allowed. */
3964 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3966 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3970 /* if start == len || (stride > 0 && start < len)
3971 || (stride < 0 && start > len),
3972 then the array section contains at least one element. In this
3973 case, there is an out-of-bounds access if
3974 (start < lower || start > upper). */
3975 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3976 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3977 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3978 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3979 && comp_start_end
== CMP_GT
))
3981 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3983 gfc_warning ("Lower array reference at %L is out of bounds "
3984 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3985 mpz_get_si (AR_START
->value
.integer
),
3986 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3989 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3991 gfc_warning ("Lower array reference at %L is out of bounds "
3992 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3993 mpz_get_si (AR_START
->value
.integer
),
3994 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3999 /* If we can compute the highest index of the array section,
4000 then it also has to be between lower and upper. */
4001 mpz_init (last_value
);
4002 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4005 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4007 gfc_warning ("Upper array reference at %L is out of bounds "
4008 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4009 mpz_get_si (last_value
),
4010 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4011 mpz_clear (last_value
);
4014 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4016 gfc_warning ("Upper array reference at %L is out of bounds "
4017 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4018 mpz_get_si (last_value
),
4019 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4020 mpz_clear (last_value
);
4024 mpz_clear (last_value
);
4032 gfc_internal_error ("check_dimension(): Bad array reference");
4039 /* Compare an array reference with an array specification. */
4042 compare_spec_to_ref (gfc_array_ref
*ar
)
4049 /* TODO: Full array sections are only allowed as actual parameters. */
4050 if (as
->type
== AS_ASSUMED_SIZE
4051 && (/*ar->type == AR_FULL
4052 ||*/ (ar
->type
== AR_SECTION
4053 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4055 gfc_error ("Rightmost upper bound of assumed size array section "
4056 "not specified at %L", &ar
->where
);
4060 if (ar
->type
== AR_FULL
)
4063 if (as
->rank
!= ar
->dimen
)
4065 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4066 &ar
->where
, ar
->dimen
, as
->rank
);
4070 /* ar->codimen == 0 is a local array. */
4071 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4073 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4074 &ar
->where
, ar
->codimen
, as
->corank
);
4078 for (i
= 0; i
< as
->rank
; i
++)
4079 if (!check_dimension (i
, ar
, as
))
4082 /* Local access has no coarray spec. */
4083 if (ar
->codimen
!= 0)
4084 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4086 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4087 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4089 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4090 i
+ 1 - as
->rank
, &ar
->where
);
4093 if (!check_dimension (i
, ar
, as
))
4101 /* Resolve one part of an array index. */
4104 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4105 int force_index_integer_kind
)
4112 if (!gfc_resolve_expr (index
))
4115 if (check_scalar
&& index
->rank
!= 0)
4117 gfc_error ("Array index at %L must be scalar", &index
->where
);
4121 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4123 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4124 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4128 if (index
->ts
.type
== BT_REAL
)
4129 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4133 if ((index
->ts
.kind
!= gfc_index_integer_kind
4134 && force_index_integer_kind
)
4135 || index
->ts
.type
!= BT_INTEGER
)
4138 ts
.type
= BT_INTEGER
;
4139 ts
.kind
= gfc_index_integer_kind
;
4141 gfc_convert_type_warn (index
, &ts
, 2, 0);
4147 /* Resolve one part of an array index. */
4150 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4152 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4155 /* Resolve a dim argument to an intrinsic function. */
4158 gfc_resolve_dim_arg (gfc_expr
*dim
)
4163 if (!gfc_resolve_expr (dim
))
4168 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4173 if (dim
->ts
.type
!= BT_INTEGER
)
4175 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4179 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4184 ts
.type
= BT_INTEGER
;
4185 ts
.kind
= gfc_index_integer_kind
;
4187 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4193 /* Given an expression that contains array references, update those array
4194 references to point to the right array specifications. While this is
4195 filled in during matching, this information is difficult to save and load
4196 in a module, so we take care of it here.
4198 The idea here is that the original array reference comes from the
4199 base symbol. We traverse the list of reference structures, setting
4200 the stored reference to references. Component references can
4201 provide an additional array specification. */
4204 find_array_spec (gfc_expr
*e
)
4210 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4211 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4213 as
= e
->symtree
->n
.sym
->as
;
4215 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4220 gfc_internal_error ("find_array_spec(): Missing spec");
4227 c
= ref
->u
.c
.component
;
4228 if (c
->attr
.dimension
)
4231 gfc_internal_error ("find_array_spec(): unused as(1)");
4242 gfc_internal_error ("find_array_spec(): unused as(2)");
4246 /* Resolve an array reference. */
4249 resolve_array_ref (gfc_array_ref
*ar
)
4251 int i
, check_scalar
;
4254 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4256 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4258 /* Do not force gfc_index_integer_kind for the start. We can
4259 do fine with any integer kind. This avoids temporary arrays
4260 created for indexing with a vector. */
4261 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4263 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4265 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4270 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4274 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4278 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4279 if (e
->expr_type
== EXPR_VARIABLE
4280 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4281 ar
->start
[i
] = gfc_get_parentheses (e
);
4285 gfc_error ("Array index at %L is an array of rank %d",
4286 &ar
->c_where
[i
], e
->rank
);
4290 /* Fill in the upper bound, which may be lower than the
4291 specified one for something like a(2:10:5), which is
4292 identical to a(2:7:5). Only relevant for strides not equal
4293 to one. Don't try a division by zero. */
4294 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4295 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4296 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4297 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4301 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4303 if (ar
->end
[i
] == NULL
)
4306 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4308 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4310 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4311 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4313 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4324 if (ar
->type
== AR_FULL
)
4326 if (ar
->as
->rank
== 0)
4327 ar
->type
= AR_ELEMENT
;
4329 /* Make sure array is the same as array(:,:), this way
4330 we don't need to special case all the time. */
4331 ar
->dimen
= ar
->as
->rank
;
4332 for (i
= 0; i
< ar
->dimen
; i
++)
4334 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4336 gcc_assert (ar
->start
[i
] == NULL
);
4337 gcc_assert (ar
->end
[i
] == NULL
);
4338 gcc_assert (ar
->stride
[i
] == NULL
);
4342 /* If the reference type is unknown, figure out what kind it is. */
4344 if (ar
->type
== AR_UNKNOWN
)
4346 ar
->type
= AR_ELEMENT
;
4347 for (i
= 0; i
< ar
->dimen
; i
++)
4348 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4349 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4351 ar
->type
= AR_SECTION
;
4356 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4359 if (ar
->as
->corank
&& ar
->codimen
== 0)
4362 ar
->codimen
= ar
->as
->corank
;
4363 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4364 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4372 resolve_substring (gfc_ref
*ref
)
4374 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4376 if (ref
->u
.ss
.start
!= NULL
)
4378 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4381 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4383 gfc_error ("Substring start index at %L must be of type INTEGER",
4384 &ref
->u
.ss
.start
->where
);
4388 if (ref
->u
.ss
.start
->rank
!= 0)
4390 gfc_error ("Substring start index at %L must be scalar",
4391 &ref
->u
.ss
.start
->where
);
4395 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4396 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4397 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4399 gfc_error ("Substring start index at %L is less than one",
4400 &ref
->u
.ss
.start
->where
);
4405 if (ref
->u
.ss
.end
!= NULL
)
4407 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4410 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4412 gfc_error ("Substring end index at %L must be of type INTEGER",
4413 &ref
->u
.ss
.end
->where
);
4417 if (ref
->u
.ss
.end
->rank
!= 0)
4419 gfc_error ("Substring end index at %L must be scalar",
4420 &ref
->u
.ss
.end
->where
);
4424 if (ref
->u
.ss
.length
!= NULL
4425 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4426 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4427 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4429 gfc_error ("Substring end index at %L exceeds the string length",
4430 &ref
->u
.ss
.start
->where
);
4434 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4435 gfc_integer_kinds
[k
].huge
) == CMP_GT
4436 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4437 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4439 gfc_error ("Substring end index at %L is too large",
4440 &ref
->u
.ss
.end
->where
);
4449 /* This function supplies missing substring charlens. */
4452 gfc_resolve_substring_charlen (gfc_expr
*e
)
4455 gfc_expr
*start
, *end
;
4457 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4458 if (char_ref
->type
== REF_SUBSTRING
)
4464 gcc_assert (char_ref
->next
== NULL
);
4468 if (e
->ts
.u
.cl
->length
)
4469 gfc_free_expr (e
->ts
.u
.cl
->length
);
4470 else if (e
->expr_type
== EXPR_VARIABLE
4471 && e
->symtree
->n
.sym
->attr
.dummy
)
4475 e
->ts
.type
= BT_CHARACTER
;
4476 e
->ts
.kind
= gfc_default_character_kind
;
4479 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4481 if (char_ref
->u
.ss
.start
)
4482 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4484 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4486 if (char_ref
->u
.ss
.end
)
4487 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4488 else if (e
->expr_type
== EXPR_VARIABLE
)
4489 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4495 gfc_free_expr (start
);
4496 gfc_free_expr (end
);
4500 /* Length = (end - start +1). */
4501 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4502 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4503 gfc_get_int_expr (gfc_default_integer_kind
,
4506 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4507 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4509 /* Make sure that the length is simplified. */
4510 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4511 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4515 /* Resolve subtype references. */
4518 resolve_ref (gfc_expr
*expr
)
4520 int current_part_dimension
, n_components
, seen_part_dimension
;
4523 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4524 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4526 find_array_spec (expr
);
4530 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4534 if (!resolve_array_ref (&ref
->u
.ar
))
4542 if (!resolve_substring (ref
))
4547 /* Check constraints on part references. */
4549 current_part_dimension
= 0;
4550 seen_part_dimension
= 0;
4553 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4558 switch (ref
->u
.ar
.type
)
4561 /* Coarray scalar. */
4562 if (ref
->u
.ar
.as
->rank
== 0)
4564 current_part_dimension
= 0;
4569 current_part_dimension
= 1;
4573 current_part_dimension
= 0;
4577 gfc_internal_error ("resolve_ref(): Bad array reference");
4583 if (current_part_dimension
|| seen_part_dimension
)
4586 if (ref
->u
.c
.component
->attr
.pointer
4587 || ref
->u
.c
.component
->attr
.proc_pointer
4588 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4589 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4591 gfc_error ("Component to the right of a part reference "
4592 "with nonzero rank must not have the POINTER "
4593 "attribute at %L", &expr
->where
);
4596 else if (ref
->u
.c
.component
->attr
.allocatable
4597 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4598 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4601 gfc_error ("Component to the right of a part reference "
4602 "with nonzero rank must not have the ALLOCATABLE "
4603 "attribute at %L", &expr
->where
);
4615 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4616 || ref
->next
== NULL
)
4617 && current_part_dimension
4618 && seen_part_dimension
)
4620 gfc_error ("Two or more part references with nonzero rank must "
4621 "not be specified at %L", &expr
->where
);
4625 if (ref
->type
== REF_COMPONENT
)
4627 if (current_part_dimension
)
4628 seen_part_dimension
= 1;
4630 /* reset to make sure */
4631 current_part_dimension
= 0;
4639 /* Given an expression, determine its shape. This is easier than it sounds.
4640 Leaves the shape array NULL if it is not possible to determine the shape. */
4643 expression_shape (gfc_expr
*e
)
4645 mpz_t array
[GFC_MAX_DIMENSIONS
];
4648 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4651 for (i
= 0; i
< e
->rank
; i
++)
4652 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4655 e
->shape
= gfc_get_shape (e
->rank
);
4657 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4662 for (i
--; i
>= 0; i
--)
4663 mpz_clear (array
[i
]);
4667 /* Given a variable expression node, compute the rank of the expression by
4668 examining the base symbol and any reference structures it may have. */
4671 expression_rank (gfc_expr
*e
)
4676 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4677 could lead to serious confusion... */
4678 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4682 if (e
->expr_type
== EXPR_ARRAY
)
4684 /* Constructors can have a rank different from one via RESHAPE(). */
4686 if (e
->symtree
== NULL
)
4692 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4693 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4699 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4701 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4702 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4703 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4705 if (ref
->type
!= REF_ARRAY
)
4708 if (ref
->u
.ar
.type
== AR_FULL
)
4710 rank
= ref
->u
.ar
.as
->rank
;
4714 if (ref
->u
.ar
.type
== AR_SECTION
)
4716 /* Figure out the rank of the section. */
4718 gfc_internal_error ("expression_rank(): Two array specs");
4720 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4721 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4722 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4732 expression_shape (e
);
4736 /* Resolve a variable expression. */
4739 resolve_variable (gfc_expr
*e
)
4746 if (e
->symtree
== NULL
)
4748 sym
= e
->symtree
->n
.sym
;
4750 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4751 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4752 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4754 if (!actual_arg
|| inquiry_argument
)
4756 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4757 "be used as actual argument", sym
->name
, &e
->where
);
4761 /* TS 29113, 407b. */
4762 else if (e
->ts
.type
== BT_ASSUMED
)
4766 gfc_error ("Assumed-type variable %s at %L may only be used "
4767 "as actual argument", sym
->name
, &e
->where
);
4770 else if (inquiry_argument
&& !first_actual_arg
)
4772 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4773 for all inquiry functions in resolve_function; the reason is
4774 that the function-name resolution happens too late in that
4776 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4777 "an inquiry function shall be the first argument",
4778 sym
->name
, &e
->where
);
4782 /* TS 29113, C535b. */
4783 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4784 && CLASS_DATA (sym
)->as
4785 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4786 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4787 && sym
->as
->type
== AS_ASSUMED_RANK
))
4791 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4792 "actual argument", sym
->name
, &e
->where
);
4795 else if (inquiry_argument
&& !first_actual_arg
)
4797 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4798 for all inquiry functions in resolve_function; the reason is
4799 that the function-name resolution happens too late in that
4801 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4802 "to an inquiry function shall be the first argument",
4803 sym
->name
, &e
->where
);
4808 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4809 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4810 && e
->ref
->next
== NULL
))
4812 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4813 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4816 /* TS 29113, 407b. */
4817 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4818 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4819 && e
->ref
->next
== NULL
))
4821 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4822 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4826 /* TS 29113, C535b. */
4827 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4828 && CLASS_DATA (sym
)->as
4829 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4830 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4831 && sym
->as
->type
== AS_ASSUMED_RANK
))
4833 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4834 && e
->ref
->next
== NULL
))
4836 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4837 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4842 /* If this is an associate-name, it may be parsed with an array reference
4843 in error even though the target is scalar. Fail directly in this case.
4844 TODO Understand why class scalar expressions must be excluded. */
4845 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4847 if (sym
->ts
.type
== BT_CLASS
)
4848 gfc_fix_class_refs (e
);
4849 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4853 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4854 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4856 /* On the other hand, the parser may not have known this is an array;
4857 in this case, we have to add a FULL reference. */
4858 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4860 e
->ref
= gfc_get_ref ();
4861 e
->ref
->type
= REF_ARRAY
;
4862 e
->ref
->u
.ar
.type
= AR_FULL
;
4863 e
->ref
->u
.ar
.dimen
= 0;
4866 if (e
->ref
&& !resolve_ref (e
))
4869 if (sym
->attr
.flavor
== FL_PROCEDURE
4870 && (!sym
->attr
.function
4871 || (sym
->attr
.function
&& sym
->result
4872 && sym
->result
->attr
.proc_pointer
4873 && !sym
->result
->attr
.function
)))
4875 e
->ts
.type
= BT_PROCEDURE
;
4876 goto resolve_procedure
;
4879 if (sym
->ts
.type
!= BT_UNKNOWN
)
4880 gfc_variable_attr (e
, &e
->ts
);
4883 /* Must be a simple variable reference. */
4884 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4889 if (check_assumed_size_reference (sym
, e
))
4892 /* Deal with forward references to entries during resolve_code, to
4893 satisfy, at least partially, 12.5.2.5. */
4894 if (gfc_current_ns
->entries
4895 && current_entry_id
== sym
->entry_id
4898 && cs_base
->current
->op
!= EXEC_ENTRY
)
4900 gfc_entry_list
*entry
;
4901 gfc_formal_arglist
*formal
;
4903 bool seen
, saved_specification_expr
;
4905 /* If the symbol is a dummy... */
4906 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4908 entry
= gfc_current_ns
->entries
;
4911 /* ...test if the symbol is a parameter of previous entries. */
4912 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4913 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4915 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4922 /* If it has not been seen as a dummy, this is an error. */
4925 if (specification_expr
)
4926 gfc_error ("Variable '%s', used in a specification expression"
4927 ", is referenced at %L before the ENTRY statement "
4928 "in which it is a parameter",
4929 sym
->name
, &cs_base
->current
->loc
);
4931 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4932 "statement in which it is a parameter",
4933 sym
->name
, &cs_base
->current
->loc
);
4938 /* Now do the same check on the specification expressions. */
4939 saved_specification_expr
= specification_expr
;
4940 specification_expr
= true;
4941 if (sym
->ts
.type
== BT_CHARACTER
4942 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4946 for (n
= 0; n
< sym
->as
->rank
; n
++)
4948 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4950 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4953 specification_expr
= saved_specification_expr
;
4956 /* Update the symbol's entry level. */
4957 sym
->entry_id
= current_entry_id
+ 1;
4960 /* If a symbol has been host_associated mark it. This is used latter,
4961 to identify if aliasing is possible via host association. */
4962 if (sym
->attr
.flavor
== FL_VARIABLE
4963 && gfc_current_ns
->parent
4964 && (gfc_current_ns
->parent
== sym
->ns
4965 || (gfc_current_ns
->parent
->parent
4966 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
4967 sym
->attr
.host_assoc
= 1;
4970 if (t
&& !resolve_procedure_expression (e
))
4973 /* F2008, C617 and C1229. */
4974 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
4975 && gfc_is_coindexed (e
))
4977 gfc_ref
*ref
, *ref2
= NULL
;
4979 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4981 if (ref
->type
== REF_COMPONENT
)
4983 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4987 for ( ; ref
; ref
= ref
->next
)
4988 if (ref
->type
== REF_COMPONENT
)
4991 /* Expression itself is not coindexed object. */
4992 if (ref
&& e
->ts
.type
== BT_CLASS
)
4994 gfc_error ("Polymorphic subobject of coindexed object at %L",
4999 /* Expression itself is coindexed object. */
5003 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5004 for ( ; c
; c
= c
->next
)
5005 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5007 gfc_error ("Coindexed object with polymorphic allocatable "
5008 "subcomponent at %L", &e
->where
);
5019 /* Checks to see that the correct symbol has been host associated.
5020 The only situation where this arises is that in which a twice
5021 contained function is parsed after the host association is made.
5022 Therefore, on detecting this, change the symbol in the expression
5023 and convert the array reference into an actual arglist if the old
5024 symbol is a variable. */
5026 check_host_association (gfc_expr
*e
)
5028 gfc_symbol
*sym
, *old_sym
;
5032 gfc_actual_arglist
*arg
, *tail
= NULL
;
5033 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5035 /* If the expression is the result of substitution in
5036 interface.c(gfc_extend_expr) because there is no way in
5037 which the host association can be wrong. */
5038 if (e
->symtree
== NULL
5039 || e
->symtree
->n
.sym
== NULL
5040 || e
->user_operator
)
5043 old_sym
= e
->symtree
->n
.sym
;
5045 if (gfc_current_ns
->parent
5046 && old_sym
->ns
!= gfc_current_ns
)
5048 /* Use the 'USE' name so that renamed module symbols are
5049 correctly handled. */
5050 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5052 if (sym
&& old_sym
!= sym
5053 && sym
->ts
.type
== old_sym
->ts
.type
5054 && sym
->attr
.flavor
== FL_PROCEDURE
5055 && sym
->attr
.contained
)
5057 /* Clear the shape, since it might not be valid. */
5058 gfc_free_shape (&e
->shape
, e
->rank
);
5060 /* Give the expression the right symtree! */
5061 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5062 gcc_assert (st
!= NULL
);
5064 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5065 || e
->expr_type
== EXPR_FUNCTION
)
5067 /* Original was function so point to the new symbol, since
5068 the actual argument list is already attached to the
5070 e
->value
.function
.esym
= NULL
;
5075 /* Original was variable so convert array references into
5076 an actual arglist. This does not need any checking now
5077 since resolve_function will take care of it. */
5078 e
->value
.function
.actual
= NULL
;
5079 e
->expr_type
= EXPR_FUNCTION
;
5082 /* Ambiguity will not arise if the array reference is not
5083 the last reference. */
5084 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5085 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5088 gcc_assert (ref
->type
== REF_ARRAY
);
5090 /* Grab the start expressions from the array ref and
5091 copy them into actual arguments. */
5092 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5094 arg
= gfc_get_actual_arglist ();
5095 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5096 if (e
->value
.function
.actual
== NULL
)
5097 tail
= e
->value
.function
.actual
= arg
;
5105 /* Dump the reference list and set the rank. */
5106 gfc_free_ref_list (e
->ref
);
5108 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5111 gfc_resolve_expr (e
);
5115 /* This might have changed! */
5116 return e
->expr_type
== EXPR_FUNCTION
;
5121 gfc_resolve_character_operator (gfc_expr
*e
)
5123 gfc_expr
*op1
= e
->value
.op
.op1
;
5124 gfc_expr
*op2
= e
->value
.op
.op2
;
5125 gfc_expr
*e1
= NULL
;
5126 gfc_expr
*e2
= NULL
;
5128 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5130 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5131 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5132 else if (op1
->expr_type
== EXPR_CONSTANT
)
5133 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5134 op1
->value
.character
.length
);
5136 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5137 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5138 else if (op2
->expr_type
== EXPR_CONSTANT
)
5139 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5140 op2
->value
.character
.length
);
5142 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5152 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5153 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5154 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5155 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5156 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5162 /* Ensure that an character expression has a charlen and, if possible, a
5163 length expression. */
5166 fixup_charlen (gfc_expr
*e
)
5168 /* The cases fall through so that changes in expression type and the need
5169 for multiple fixes are picked up. In all circumstances, a charlen should
5170 be available for the middle end to hang a backend_decl on. */
5171 switch (e
->expr_type
)
5174 gfc_resolve_character_operator (e
);
5177 if (e
->expr_type
== EXPR_ARRAY
)
5178 gfc_resolve_character_array_constructor (e
);
5180 case EXPR_SUBSTRING
:
5181 if (!e
->ts
.u
.cl
&& e
->ref
)
5182 gfc_resolve_substring_charlen (e
);
5186 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5193 /* Update an actual argument to include the passed-object for type-bound
5194 procedures at the right position. */
5196 static gfc_actual_arglist
*
5197 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5200 gcc_assert (argpos
> 0);
5204 gfc_actual_arglist
* result
;
5206 result
= gfc_get_actual_arglist ();
5210 result
->name
= name
;
5216 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5218 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5223 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5226 extract_compcall_passed_object (gfc_expr
* e
)
5230 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5232 if (e
->value
.compcall
.base_object
)
5233 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5236 po
= gfc_get_expr ();
5237 po
->expr_type
= EXPR_VARIABLE
;
5238 po
->symtree
= e
->symtree
;
5239 po
->ref
= gfc_copy_ref (e
->ref
);
5240 po
->where
= e
->where
;
5243 if (!gfc_resolve_expr (po
))
5250 /* Update the arglist of an EXPR_COMPCALL expression to include the
5254 update_compcall_arglist (gfc_expr
* e
)
5257 gfc_typebound_proc
* tbp
;
5259 tbp
= e
->value
.compcall
.tbp
;
5264 po
= extract_compcall_passed_object (e
);
5268 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5274 gcc_assert (tbp
->pass_arg_num
> 0);
5275 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5283 /* Extract the passed object from a PPC call (a copy of it). */
5286 extract_ppc_passed_object (gfc_expr
*e
)
5291 po
= gfc_get_expr ();
5292 po
->expr_type
= EXPR_VARIABLE
;
5293 po
->symtree
= e
->symtree
;
5294 po
->ref
= gfc_copy_ref (e
->ref
);
5295 po
->where
= e
->where
;
5297 /* Remove PPC reference. */
5299 while ((*ref
)->next
)
5300 ref
= &(*ref
)->next
;
5301 gfc_free_ref_list (*ref
);
5304 if (!gfc_resolve_expr (po
))
5311 /* Update the actual arglist of a procedure pointer component to include the
5315 update_ppc_arglist (gfc_expr
* e
)
5319 gfc_typebound_proc
* tb
;
5321 ppc
= gfc_get_proc_ptr_comp (e
);
5329 else if (tb
->nopass
)
5332 po
= extract_ppc_passed_object (e
);
5339 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5344 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5346 gfc_error ("Base object for procedure-pointer component call at %L is of"
5347 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5351 gcc_assert (tb
->pass_arg_num
> 0);
5352 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5360 /* Check that the object a TBP is called on is valid, i.e. it must not be
5361 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5364 check_typebound_baseobject (gfc_expr
* e
)
5367 bool return_value
= false;
5369 base
= extract_compcall_passed_object (e
);
5373 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5375 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5379 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5381 gfc_error ("Base object for type-bound procedure call at %L is of"
5382 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5386 /* F08:C1230. If the procedure called is NOPASS,
5387 the base object must be scalar. */
5388 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5390 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5391 " be scalar", &e
->where
);
5395 return_value
= true;
5398 gfc_free_expr (base
);
5399 return return_value
;
5403 /* Resolve a call to a type-bound procedure, either function or subroutine,
5404 statically from the data in an EXPR_COMPCALL expression. The adapted
5405 arglist and the target-procedure symtree are returned. */
5408 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5409 gfc_actual_arglist
** actual
)
5411 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5412 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5414 /* Update the actual arglist for PASS. */
5415 if (!update_compcall_arglist (e
))
5418 *actual
= e
->value
.compcall
.actual
;
5419 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5421 gfc_free_ref_list (e
->ref
);
5423 e
->value
.compcall
.actual
= NULL
;
5425 /* If we find a deferred typebound procedure, check for derived types
5426 that an overriding typebound procedure has not been missed. */
5427 if (e
->value
.compcall
.name
5428 && !e
->value
.compcall
.tbp
->non_overridable
5429 && e
->value
.compcall
.base_object
5430 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5433 gfc_symbol
*derived
;
5435 /* Use the derived type of the base_object. */
5436 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5439 /* If necessary, go through the inheritance chain. */
5440 while (!st
&& derived
)
5442 /* Look for the typebound procedure 'name'. */
5443 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5444 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5445 e
->value
.compcall
.name
);
5447 derived
= gfc_get_derived_super_type (derived
);
5450 /* Now find the specific name in the derived type namespace. */
5451 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5452 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5453 derived
->ns
, 1, &st
);
5461 /* Get the ultimate declared type from an expression. In addition,
5462 return the last class/derived type reference and the copy of the
5463 reference list. If check_types is set true, derived types are
5464 identified as well as class references. */
5466 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5467 gfc_expr
*e
, bool check_types
)
5469 gfc_symbol
*declared
;
5476 *new_ref
= gfc_copy_ref (e
->ref
);
5478 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5480 if (ref
->type
!= REF_COMPONENT
)
5483 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5484 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5485 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5487 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5493 if (declared
== NULL
)
5494 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5500 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5501 which of the specific bindings (if any) matches the arglist and transform
5502 the expression into a call of that binding. */
5505 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5507 gfc_typebound_proc
* genproc
;
5508 const char* genname
;
5510 gfc_symbol
*derived
;
5512 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5513 genname
= e
->value
.compcall
.name
;
5514 genproc
= e
->value
.compcall
.tbp
;
5516 if (!genproc
->is_generic
)
5519 /* Try the bindings on this type and in the inheritance hierarchy. */
5520 for (; genproc
; genproc
= genproc
->overridden
)
5524 gcc_assert (genproc
->is_generic
);
5525 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5528 gfc_actual_arglist
* args
;
5531 gcc_assert (g
->specific
);
5533 if (g
->specific
->error
)
5536 target
= g
->specific
->u
.specific
->n
.sym
;
5538 /* Get the right arglist by handling PASS/NOPASS. */
5539 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5540 if (!g
->specific
->nopass
)
5543 po
= extract_compcall_passed_object (e
);
5546 gfc_free_actual_arglist (args
);
5550 gcc_assert (g
->specific
->pass_arg_num
> 0);
5551 gcc_assert (!g
->specific
->error
);
5552 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5553 g
->specific
->pass_arg
);
5555 resolve_actual_arglist (args
, target
->attr
.proc
,
5556 is_external_proc (target
)
5557 && gfc_sym_get_dummy_args (target
) == NULL
);
5559 /* Check if this arglist matches the formal. */
5560 matches
= gfc_arglist_matches_symbol (&args
, target
);
5562 /* Clean up and break out of the loop if we've found it. */
5563 gfc_free_actual_arglist (args
);
5566 e
->value
.compcall
.tbp
= g
->specific
;
5567 genname
= g
->specific_st
->name
;
5568 /* Pass along the name for CLASS methods, where the vtab
5569 procedure pointer component has to be referenced. */
5577 /* Nothing matching found! */
5578 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5579 " '%s' at %L", genname
, &e
->where
);
5583 /* Make sure that we have the right specific instance for the name. */
5584 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5586 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5588 e
->value
.compcall
.tbp
= st
->n
.tb
;
5594 /* Resolve a call to a type-bound subroutine. */
5597 resolve_typebound_call (gfc_code
* c
, const char **name
)
5599 gfc_actual_arglist
* newactual
;
5600 gfc_symtree
* target
;
5602 /* Check that's really a SUBROUTINE. */
5603 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5605 gfc_error ("'%s' at %L should be a SUBROUTINE",
5606 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5610 if (!check_typebound_baseobject (c
->expr1
))
5613 /* Pass along the name for CLASS methods, where the vtab
5614 procedure pointer component has to be referenced. */
5616 *name
= c
->expr1
->value
.compcall
.name
;
5618 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5621 /* Transform into an ordinary EXEC_CALL for now. */
5623 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5626 c
->ext
.actual
= newactual
;
5627 c
->symtree
= target
;
5628 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5630 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5632 gfc_free_expr (c
->expr1
);
5633 c
->expr1
= gfc_get_expr ();
5634 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5635 c
->expr1
->symtree
= target
;
5636 c
->expr1
->where
= c
->loc
;
5638 return resolve_call (c
);
5642 /* Resolve a component-call expression. */
5644 resolve_compcall (gfc_expr
* e
, const char **name
)
5646 gfc_actual_arglist
* newactual
;
5647 gfc_symtree
* target
;
5649 /* Check that's really a FUNCTION. */
5650 if (!e
->value
.compcall
.tbp
->function
)
5652 gfc_error ("'%s' at %L should be a FUNCTION",
5653 e
->value
.compcall
.name
, &e
->where
);
5657 /* These must not be assign-calls! */
5658 gcc_assert (!e
->value
.compcall
.assign
);
5660 if (!check_typebound_baseobject (e
))
5663 /* Pass along the name for CLASS methods, where the vtab
5664 procedure pointer component has to be referenced. */
5666 *name
= e
->value
.compcall
.name
;
5668 if (!resolve_typebound_generic_call (e
, name
))
5670 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5672 /* Take the rank from the function's symbol. */
5673 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5674 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5676 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5677 arglist to the TBP's binding target. */
5679 if (!resolve_typebound_static (e
, &target
, &newactual
))
5682 e
->value
.function
.actual
= newactual
;
5683 e
->value
.function
.name
= NULL
;
5684 e
->value
.function
.esym
= target
->n
.sym
;
5685 e
->value
.function
.isym
= NULL
;
5686 e
->symtree
= target
;
5687 e
->ts
= target
->n
.sym
->ts
;
5688 e
->expr_type
= EXPR_FUNCTION
;
5690 /* Resolution is not necessary if this is a class subroutine; this
5691 function only has to identify the specific proc. Resolution of
5692 the call will be done next in resolve_typebound_call. */
5693 return gfc_resolve_expr (e
);
5697 static bool resolve_fl_derived (gfc_symbol
*sym
);
5700 /* Resolve a typebound function, or 'method'. First separate all
5701 the non-CLASS references by calling resolve_compcall directly. */
5704 resolve_typebound_function (gfc_expr
* e
)
5706 gfc_symbol
*declared
;
5718 /* Deal with typebound operators for CLASS objects. */
5719 expr
= e
->value
.compcall
.base_object
;
5720 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5721 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5723 /* If the base_object is not a variable, the corresponding actual
5724 argument expression must be stored in e->base_expression so
5725 that the corresponding tree temporary can be used as the base
5726 object in gfc_conv_procedure_call. */
5727 if (expr
->expr_type
!= EXPR_VARIABLE
)
5729 gfc_actual_arglist
*args
;
5731 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5733 if (expr
== args
->expr
)
5738 /* Since the typebound operators are generic, we have to ensure
5739 that any delays in resolution are corrected and that the vtab
5742 declared
= ts
.u
.derived
;
5743 c
= gfc_find_component (declared
, "_vptr", true, true);
5744 if (c
->ts
.u
.derived
== NULL
)
5745 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5747 if (!resolve_compcall (e
, &name
))
5750 /* Use the generic name if it is there. */
5751 name
= name
? name
: e
->value
.function
.esym
->name
;
5752 e
->symtree
= expr
->symtree
;
5753 e
->ref
= gfc_copy_ref (expr
->ref
);
5754 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5756 /* Trim away the extraneous references that emerge from nested
5757 use of interface.c (extend_expr). */
5758 if (class_ref
&& class_ref
->next
)
5760 gfc_free_ref_list (class_ref
->next
);
5761 class_ref
->next
= NULL
;
5763 else if (e
->ref
&& !class_ref
)
5765 gfc_free_ref_list (e
->ref
);
5769 gfc_add_vptr_component (e
);
5770 gfc_add_component_ref (e
, name
);
5771 e
->value
.function
.esym
= NULL
;
5772 if (expr
->expr_type
!= EXPR_VARIABLE
)
5773 e
->base_expr
= expr
;
5778 return resolve_compcall (e
, NULL
);
5780 if (!resolve_ref (e
))
5783 /* Get the CLASS declared type. */
5784 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5786 if (!resolve_fl_derived (declared
))
5789 /* Weed out cases of the ultimate component being a derived type. */
5790 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5791 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5793 gfc_free_ref_list (new_ref
);
5794 return resolve_compcall (e
, NULL
);
5797 c
= gfc_find_component (declared
, "_data", true, true);
5798 declared
= c
->ts
.u
.derived
;
5800 /* Treat the call as if it is a typebound procedure, in order to roll
5801 out the correct name for the specific function. */
5802 if (!resolve_compcall (e
, &name
))
5804 gfc_free_ref_list (new_ref
);
5811 /* Convert the expression to a procedure pointer component call. */
5812 e
->value
.function
.esym
= NULL
;
5818 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5819 gfc_add_vptr_component (e
);
5820 gfc_add_component_ref (e
, name
);
5822 /* Recover the typespec for the expression. This is really only
5823 necessary for generic procedures, where the additional call
5824 to gfc_add_component_ref seems to throw the collection of the
5825 correct typespec. */
5829 gfc_free_ref_list (new_ref
);
5834 /* Resolve a typebound subroutine, or 'method'. First separate all
5835 the non-CLASS references by calling resolve_typebound_call
5839 resolve_typebound_subroutine (gfc_code
*code
)
5841 gfc_symbol
*declared
;
5851 st
= code
->expr1
->symtree
;
5853 /* Deal with typebound operators for CLASS objects. */
5854 expr
= code
->expr1
->value
.compcall
.base_object
;
5855 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5856 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5858 /* If the base_object is not a variable, the corresponding actual
5859 argument expression must be stored in e->base_expression so
5860 that the corresponding tree temporary can be used as the base
5861 object in gfc_conv_procedure_call. */
5862 if (expr
->expr_type
!= EXPR_VARIABLE
)
5864 gfc_actual_arglist
*args
;
5866 args
= code
->expr1
->value
.function
.actual
;
5867 for (; args
; args
= args
->next
)
5868 if (expr
== args
->expr
)
5872 /* Since the typebound operators are generic, we have to ensure
5873 that any delays in resolution are corrected and that the vtab
5875 declared
= expr
->ts
.u
.derived
;
5876 c
= gfc_find_component (declared
, "_vptr", true, true);
5877 if (c
->ts
.u
.derived
== NULL
)
5878 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5880 if (!resolve_typebound_call (code
, &name
))
5883 /* Use the generic name if it is there. */
5884 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5885 code
->expr1
->symtree
= expr
->symtree
;
5886 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5888 /* Trim away the extraneous references that emerge from nested
5889 use of interface.c (extend_expr). */
5890 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5891 if (class_ref
&& class_ref
->next
)
5893 gfc_free_ref_list (class_ref
->next
);
5894 class_ref
->next
= NULL
;
5896 else if (code
->expr1
->ref
&& !class_ref
)
5898 gfc_free_ref_list (code
->expr1
->ref
);
5899 code
->expr1
->ref
= NULL
;
5902 /* Now use the procedure in the vtable. */
5903 gfc_add_vptr_component (code
->expr1
);
5904 gfc_add_component_ref (code
->expr1
, name
);
5905 code
->expr1
->value
.function
.esym
= NULL
;
5906 if (expr
->expr_type
!= EXPR_VARIABLE
)
5907 code
->expr1
->base_expr
= expr
;
5912 return resolve_typebound_call (code
, NULL
);
5914 if (!resolve_ref (code
->expr1
))
5917 /* Get the CLASS declared type. */
5918 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5920 /* Weed out cases of the ultimate component being a derived type. */
5921 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5922 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5924 gfc_free_ref_list (new_ref
);
5925 return resolve_typebound_call (code
, NULL
);
5928 if (!resolve_typebound_call (code
, &name
))
5930 gfc_free_ref_list (new_ref
);
5933 ts
= code
->expr1
->ts
;
5937 /* Convert the expression to a procedure pointer component call. */
5938 code
->expr1
->value
.function
.esym
= NULL
;
5939 code
->expr1
->symtree
= st
;
5942 code
->expr1
->ref
= new_ref
;
5944 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5945 gfc_add_vptr_component (code
->expr1
);
5946 gfc_add_component_ref (code
->expr1
, name
);
5948 /* Recover the typespec for the expression. This is really only
5949 necessary for generic procedures, where the additional call
5950 to gfc_add_component_ref seems to throw the collection of the
5951 correct typespec. */
5952 code
->expr1
->ts
= ts
;
5955 gfc_free_ref_list (new_ref
);
5961 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5964 resolve_ppc_call (gfc_code
* c
)
5966 gfc_component
*comp
;
5968 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
5969 gcc_assert (comp
!= NULL
);
5971 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5972 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5974 if (!comp
->attr
.subroutine
)
5975 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5977 if (!resolve_ref (c
->expr1
))
5980 if (!update_ppc_arglist (c
->expr1
))
5983 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5985 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5986 !(comp
->ts
.interface
5987 && comp
->ts
.interface
->formal
)))
5990 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5996 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5999 resolve_expr_ppc (gfc_expr
* e
)
6001 gfc_component
*comp
;
6003 comp
= gfc_get_proc_ptr_comp (e
);
6004 gcc_assert (comp
!= NULL
);
6006 /* Convert to EXPR_FUNCTION. */
6007 e
->expr_type
= EXPR_FUNCTION
;
6008 e
->value
.function
.isym
= NULL
;
6009 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6011 if (comp
->as
!= NULL
)
6012 e
->rank
= comp
->as
->rank
;
6014 if (!comp
->attr
.function
)
6015 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6017 if (!resolve_ref (e
))
6020 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6021 !(comp
->ts
.interface
6022 && comp
->ts
.interface
->formal
)))
6025 if (!update_ppc_arglist (e
))
6028 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6035 gfc_is_expandable_expr (gfc_expr
*e
)
6037 gfc_constructor
*con
;
6039 if (e
->expr_type
== EXPR_ARRAY
)
6041 /* Traverse the constructor looking for variables that are flavor
6042 parameter. Parameters must be expanded since they are fully used at
6044 con
= gfc_constructor_first (e
->value
.constructor
);
6045 for (; con
; con
= gfc_constructor_next (con
))
6047 if (con
->expr
->expr_type
== EXPR_VARIABLE
6048 && con
->expr
->symtree
6049 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6050 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6052 if (con
->expr
->expr_type
== EXPR_ARRAY
6053 && gfc_is_expandable_expr (con
->expr
))
6061 /* Resolve an expression. That is, make sure that types of operands agree
6062 with their operators, intrinsic operators are converted to function calls
6063 for overloaded types and unresolved function references are resolved. */
6066 gfc_resolve_expr (gfc_expr
*e
)
6069 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6074 /* inquiry_argument only applies to variables. */
6075 inquiry_save
= inquiry_argument
;
6076 actual_arg_save
= actual_arg
;
6077 first_actual_arg_save
= first_actual_arg
;
6079 if (e
->expr_type
!= EXPR_VARIABLE
)
6081 inquiry_argument
= false;
6083 first_actual_arg
= false;
6086 switch (e
->expr_type
)
6089 t
= resolve_operator (e
);
6095 if (check_host_association (e
))
6096 t
= resolve_function (e
);
6099 t
= resolve_variable (e
);
6101 expression_rank (e
);
6104 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6105 && e
->ref
->type
!= REF_SUBSTRING
)
6106 gfc_resolve_substring_charlen (e
);
6111 t
= resolve_typebound_function (e
);
6114 case EXPR_SUBSTRING
:
6115 t
= resolve_ref (e
);
6124 t
= resolve_expr_ppc (e
);
6129 if (!resolve_ref (e
))
6132 t
= gfc_resolve_array_constructor (e
);
6133 /* Also try to expand a constructor. */
6136 expression_rank (e
);
6137 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6138 gfc_expand_constructor (e
, false);
6141 /* This provides the opportunity for the length of constructors with
6142 character valued function elements to propagate the string length
6143 to the expression. */
6144 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6146 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6147 here rather then add a duplicate test for it above. */
6148 gfc_expand_constructor (e
, false);
6149 t
= gfc_resolve_character_array_constructor (e
);
6154 case EXPR_STRUCTURE
:
6155 t
= resolve_ref (e
);
6159 t
= resolve_structure_cons (e
, 0);
6163 t
= gfc_simplify_expr (e
, 0);
6167 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6170 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6173 inquiry_argument
= inquiry_save
;
6174 actual_arg
= actual_arg_save
;
6175 first_actual_arg
= first_actual_arg_save
;
6181 /* Resolve an expression from an iterator. They must be scalar and have
6182 INTEGER or (optionally) REAL type. */
6185 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6186 const char *name_msgid
)
6188 if (!gfc_resolve_expr (expr
))
6191 if (expr
->rank
!= 0)
6193 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6197 if (expr
->ts
.type
!= BT_INTEGER
)
6199 if (expr
->ts
.type
== BT_REAL
)
6202 return gfc_notify_std (GFC_STD_F95_DEL
,
6203 "%s at %L must be integer",
6204 _(name_msgid
), &expr
->where
);
6207 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6214 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6222 /* Resolve the expressions in an iterator structure. If REAL_OK is
6223 false allow only INTEGER type iterators, otherwise allow REAL types.
6224 Set own_scope to true for ac-implied-do and data-implied-do as those
6225 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6228 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6230 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6233 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6234 _("iterator variable")))
6237 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6238 "Start expression in DO loop"))
6241 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6242 "End expression in DO loop"))
6245 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6246 "Step expression in DO loop"))
6249 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6251 if ((iter
->step
->ts
.type
== BT_INTEGER
6252 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6253 || (iter
->step
->ts
.type
== BT_REAL
6254 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6256 gfc_error ("Step expression in DO loop at %L cannot be zero",
6257 &iter
->step
->where
);
6262 /* Convert start, end, and step to the same type as var. */
6263 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6264 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6265 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6267 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6268 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6269 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6271 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6272 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6273 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6275 if (iter
->start
->expr_type
== EXPR_CONSTANT
6276 && iter
->end
->expr_type
== EXPR_CONSTANT
6277 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6280 if (iter
->start
->ts
.type
== BT_INTEGER
)
6282 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6283 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6287 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6288 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6290 if (gfc_option
.warn_zerotrip
&&
6291 ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6292 gfc_warning ("DO loop at %L will be executed zero times"
6293 " (use -Wno-zerotrip to suppress)",
6294 &iter
->step
->where
);
6301 /* Traversal function for find_forall_index. f == 2 signals that
6302 that variable itself is not to be checked - only the references. */
6305 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6307 if (expr
->expr_type
!= EXPR_VARIABLE
)
6310 /* A scalar assignment */
6311 if (!expr
->ref
|| *f
== 1)
6313 if (expr
->symtree
->n
.sym
== sym
)
6325 /* Check whether the FORALL index appears in the expression or not.
6326 Returns true if SYM is found in EXPR. */
6329 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6331 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6338 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6339 to be a scalar INTEGER variable. The subscripts and stride are scalar
6340 INTEGERs, and if stride is a constant it must be nonzero.
6341 Furthermore "A subscript or stride in a forall-triplet-spec shall
6342 not contain a reference to any index-name in the
6343 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6346 resolve_forall_iterators (gfc_forall_iterator
*it
)
6348 gfc_forall_iterator
*iter
, *iter2
;
6350 for (iter
= it
; iter
; iter
= iter
->next
)
6352 if (gfc_resolve_expr (iter
->var
)
6353 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6354 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6357 if (gfc_resolve_expr (iter
->start
)
6358 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6359 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6360 &iter
->start
->where
);
6361 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6362 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6364 if (gfc_resolve_expr (iter
->end
)
6365 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6366 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6368 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6369 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6371 if (gfc_resolve_expr (iter
->stride
))
6373 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6374 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6375 &iter
->stride
->where
, "INTEGER");
6377 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6378 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6379 gfc_error ("FORALL stride expression at %L cannot be zero",
6380 &iter
->stride
->where
);
6382 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6383 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6386 for (iter
= it
; iter
; iter
= iter
->next
)
6387 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6389 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6390 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6391 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6392 gfc_error ("FORALL index '%s' may not appear in triplet "
6393 "specification at %L", iter
->var
->symtree
->name
,
6394 &iter2
->start
->where
);
6399 /* Given a pointer to a symbol that is a derived type, see if it's
6400 inaccessible, i.e. if it's defined in another module and the components are
6401 PRIVATE. The search is recursive if necessary. Returns zero if no
6402 inaccessible components are found, nonzero otherwise. */
6405 derived_inaccessible (gfc_symbol
*sym
)
6409 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6412 for (c
= sym
->components
; c
; c
= c
->next
)
6414 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6422 /* Resolve the argument of a deallocate expression. The expression must be
6423 a pointer or a full array. */
6426 resolve_deallocate_expr (gfc_expr
*e
)
6428 symbol_attribute attr
;
6429 int allocatable
, pointer
;
6435 if (!gfc_resolve_expr (e
))
6438 if (e
->expr_type
!= EXPR_VARIABLE
)
6441 sym
= e
->symtree
->n
.sym
;
6442 unlimited
= UNLIMITED_POLY(sym
);
6444 if (sym
->ts
.type
== BT_CLASS
)
6446 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6447 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6451 allocatable
= sym
->attr
.allocatable
;
6452 pointer
= sym
->attr
.pointer
;
6454 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6459 if (ref
->u
.ar
.type
!= AR_FULL
6460 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6461 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6466 c
= ref
->u
.c
.component
;
6467 if (c
->ts
.type
== BT_CLASS
)
6469 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6470 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6474 allocatable
= c
->attr
.allocatable
;
6475 pointer
= c
->attr
.pointer
;
6485 attr
= gfc_expr_attr (e
);
6487 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6490 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6496 if (gfc_is_coindexed (e
))
6498 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6503 && !gfc_check_vardef_context (e
, true, true, false,
6504 _("DEALLOCATE object")))
6506 if (!gfc_check_vardef_context (e
, false, true, false,
6507 _("DEALLOCATE object")))
6514 /* Returns true if the expression e contains a reference to the symbol sym. */
6516 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6518 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6525 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6527 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6531 /* Given the expression node e for an allocatable/pointer of derived type to be
6532 allocated, get the expression node to be initialized afterwards (needed for
6533 derived types with default initializers, and derived types with allocatable
6534 components that need nullification.) */
6537 gfc_expr_to_initialize (gfc_expr
*e
)
6543 result
= gfc_copy_expr (e
);
6545 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6546 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6547 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6549 ref
->u
.ar
.type
= AR_FULL
;
6551 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6552 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6557 gfc_free_shape (&result
->shape
, result
->rank
);
6559 /* Recalculate rank, shape, etc. */
6560 gfc_resolve_expr (result
);
6565 /* If the last ref of an expression is an array ref, return a copy of the
6566 expression with that one removed. Otherwise, a copy of the original
6567 expression. This is used for allocate-expressions and pointer assignment
6568 LHS, where there may be an array specification that needs to be stripped
6569 off when using gfc_check_vardef_context. */
6572 remove_last_array_ref (gfc_expr
* e
)
6577 e2
= gfc_copy_expr (e
);
6578 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6579 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6581 gfc_free_ref_list (*r
);
6590 /* Used in resolve_allocate_expr to check that a allocation-object and
6591 a source-expr are conformable. This does not catch all possible
6592 cases; in particular a runtime checking is needed. */
6595 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6598 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6600 /* First compare rank. */
6601 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6602 || (!tail
&& e1
->rank
!= e2
->rank
))
6604 gfc_error ("Source-expr at %L must be scalar or have the "
6605 "same rank as the allocate-object at %L",
6606 &e1
->where
, &e2
->where
);
6617 for (i
= 0; i
< e1
->rank
; i
++)
6619 if (tail
->u
.ar
.start
[i
] == NULL
)
6622 if (tail
->u
.ar
.end
[i
])
6624 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6625 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6626 mpz_add_ui (s
, s
, 1);
6630 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6633 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6635 gfc_error ("Source-expr at %L and allocate-object at %L must "
6636 "have the same shape", &e1
->where
, &e2
->where
);
6649 /* Resolve the expression in an ALLOCATE statement, doing the additional
6650 checks to see whether the expression is OK or not. The expression must
6651 have a trailing array reference that gives the size of the array. */
6654 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6656 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6660 symbol_attribute attr
;
6661 gfc_ref
*ref
, *ref2
;
6664 gfc_symbol
*sym
= NULL
;
6669 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6670 checking of coarrays. */
6671 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6672 if (ref
->next
== NULL
)
6675 if (ref
&& ref
->type
== REF_ARRAY
)
6676 ref
->u
.ar
.in_allocate
= true;
6678 if (!gfc_resolve_expr (e
))
6681 /* Make sure the expression is allocatable or a pointer. If it is
6682 pointer, the next-to-last reference must be a pointer. */
6686 sym
= e
->symtree
->n
.sym
;
6688 /* Check whether ultimate component is abstract and CLASS. */
6691 /* Is the allocate-object unlimited polymorphic? */
6692 unlimited
= UNLIMITED_POLY(e
);
6694 if (e
->expr_type
!= EXPR_VARIABLE
)
6697 attr
= gfc_expr_attr (e
);
6698 pointer
= attr
.pointer
;
6699 dimension
= attr
.dimension
;
6700 codimension
= attr
.codimension
;
6704 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6706 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6707 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6708 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6709 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6710 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6714 allocatable
= sym
->attr
.allocatable
;
6715 pointer
= sym
->attr
.pointer
;
6716 dimension
= sym
->attr
.dimension
;
6717 codimension
= sym
->attr
.codimension
;
6722 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6727 if (ref
->u
.ar
.codimen
> 0)
6730 for (n
= ref
->u
.ar
.dimen
;
6731 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6732 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6739 if (ref
->next
!= NULL
)
6747 gfc_error ("Coindexed allocatable object at %L",
6752 c
= ref
->u
.c
.component
;
6753 if (c
->ts
.type
== BT_CLASS
)
6755 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6756 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6757 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6758 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6759 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6763 allocatable
= c
->attr
.allocatable
;
6764 pointer
= c
->attr
.pointer
;
6765 dimension
= c
->attr
.dimension
;
6766 codimension
= c
->attr
.codimension
;
6767 is_abstract
= c
->attr
.abstract
;
6779 /* Check for F08:C628. */
6780 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6782 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6787 /* Some checks for the SOURCE tag. */
6790 /* Check F03:C631. */
6791 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6793 gfc_error ("Type of entity at %L is type incompatible with "
6794 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6798 /* Check F03:C632 and restriction following Note 6.18. */
6799 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6802 /* Check F03:C633. */
6803 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6805 gfc_error ("The allocate-object at %L and the source-expr at %L "
6806 "shall have the same kind type parameter",
6807 &e
->where
, &code
->expr3
->where
);
6811 /* Check F2008, C642. */
6812 if (code
->expr3
->ts
.type
== BT_DERIVED
6813 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6814 || (code
->expr3
->ts
.u
.derived
->from_intmod
6815 == INTMOD_ISO_FORTRAN_ENV
6816 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6817 == ISOFORTRAN_LOCK_TYPE
)))
6819 gfc_error ("The source-expr at %L shall neither be of type "
6820 "LOCK_TYPE nor have a LOCK_TYPE component if "
6821 "allocate-object at %L is a coarray",
6822 &code
->expr3
->where
, &e
->where
);
6827 /* Check F08:C629. */
6828 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6831 gcc_assert (e
->ts
.type
== BT_CLASS
);
6832 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6833 "type-spec or source-expr", sym
->name
, &e
->where
);
6837 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6839 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6840 code
->ext
.alloc
.ts
.u
.cl
->length
);
6841 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6843 gfc_error ("Allocating %s at %L with type-spec requires the same "
6844 "character-length parameter as in the declaration",
6845 sym
->name
, &e
->where
);
6850 /* In the variable definition context checks, gfc_expr_attr is used
6851 on the expression. This is fooled by the array specification
6852 present in e, thus we have to eliminate that one temporarily. */
6853 e2
= remove_last_array_ref (e
);
6856 t
= gfc_check_vardef_context (e2
, true, true, false,
6857 _("ALLOCATE object"));
6859 t
= gfc_check_vardef_context (e2
, false, true, false,
6860 _("ALLOCATE object"));
6865 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6866 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6868 /* For class arrays, the initialization with SOURCE is done
6869 using _copy and trans_call. It is convenient to exploit that
6870 when the allocated type is different from the declared type but
6871 no SOURCE exists by setting expr3. */
6872 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6874 else if (!code
->expr3
)
6876 /* Set up default initializer if needed. */
6880 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6881 ts
= code
->ext
.alloc
.ts
;
6885 if (ts
.type
== BT_CLASS
)
6886 ts
= ts
.u
.derived
->components
->ts
;
6888 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6890 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6891 init_st
->loc
= code
->loc
;
6892 init_st
->expr1
= gfc_expr_to_initialize (e
);
6893 init_st
->expr2
= init_e
;
6894 init_st
->next
= code
->next
;
6895 code
->next
= init_st
;
6898 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6900 /* Default initialization via MOLD (non-polymorphic). */
6901 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6902 gfc_resolve_expr (rhs
);
6903 gfc_free_expr (code
->expr3
);
6907 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6909 /* Make sure the vtab symbol is present when
6910 the module variables are generated. */
6911 gfc_typespec ts
= e
->ts
;
6913 ts
= code
->expr3
->ts
;
6914 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6915 ts
= code
->ext
.alloc
.ts
;
6917 gfc_find_derived_vtab (ts
.u
.derived
);
6920 e
= gfc_expr_to_initialize (e
);
6922 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6924 /* Again, make sure the vtab symbol is present when
6925 the module variables are generated. */
6926 gfc_typespec
*ts
= NULL
;
6928 ts
= &code
->expr3
->ts
;
6930 ts
= &code
->ext
.alloc
.ts
;
6937 e
= gfc_expr_to_initialize (e
);
6940 if (dimension
== 0 && codimension
== 0)
6943 /* Make sure the last reference node is an array specification. */
6945 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6946 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6948 gfc_error ("Array specification required in ALLOCATE statement "
6949 "at %L", &e
->where
);
6953 /* Make sure that the array section reference makes sense in the
6954 context of an ALLOCATE specification. */
6959 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6960 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6962 gfc_error ("Coarray specification required in ALLOCATE statement "
6963 "at %L", &e
->where
);
6967 for (i
= 0; i
< ar
->dimen
; i
++)
6969 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6972 switch (ar
->dimen_type
[i
])
6978 if (ar
->start
[i
] != NULL
6979 && ar
->end
[i
] != NULL
6980 && ar
->stride
[i
] == NULL
)
6983 /* Fall Through... */
6988 case DIMEN_THIS_IMAGE
:
6989 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6995 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6997 sym
= a
->expr
->symtree
->n
.sym
;
6999 /* TODO - check derived type components. */
7000 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7003 if ((ar
->start
[i
] != NULL
7004 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7005 || (ar
->end
[i
] != NULL
7006 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7008 gfc_error ("'%s' must not appear in the array specification at "
7009 "%L in the same ALLOCATE statement where it is "
7010 "itself allocated", sym
->name
, &ar
->where
);
7016 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7018 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7019 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7021 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7023 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7024 "statement at %L", &e
->where
);
7030 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7031 && ar
->stride
[i
] == NULL
)
7034 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7047 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7049 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7050 gfc_alloc
*a
, *p
, *q
;
7053 errmsg
= code
->expr2
;
7055 /* Check the stat variable. */
7058 gfc_check_vardef_context (stat
, false, false, false,
7059 _("STAT variable"));
7061 if ((stat
->ts
.type
!= BT_INTEGER
7062 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7063 || stat
->ref
->type
== REF_COMPONENT
)))
7065 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7066 "variable", &stat
->where
);
7068 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7069 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7071 gfc_ref
*ref1
, *ref2
;
7074 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7075 ref1
= ref1
->next
, ref2
= ref2
->next
)
7077 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7079 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7088 gfc_error ("Stat-variable at %L shall not be %sd within "
7089 "the same %s statement", &stat
->where
, fcn
, fcn
);
7095 /* Check the errmsg variable. */
7099 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7102 gfc_check_vardef_context (errmsg
, false, false, false,
7103 _("ERRMSG variable"));
7105 if ((errmsg
->ts
.type
!= BT_CHARACTER
7107 && (errmsg
->ref
->type
== REF_ARRAY
7108 || errmsg
->ref
->type
== REF_COMPONENT
)))
7109 || errmsg
->rank
> 0 )
7110 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7111 "variable", &errmsg
->where
);
7113 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7114 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7116 gfc_ref
*ref1
, *ref2
;
7119 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7120 ref1
= ref1
->next
, ref2
= ref2
->next
)
7122 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7124 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7133 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7134 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7140 /* Check that an allocate-object appears only once in the statement. */
7142 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7145 for (q
= p
->next
; q
; q
= q
->next
)
7148 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7150 /* This is a potential collision. */
7151 gfc_ref
*pr
= pe
->ref
;
7152 gfc_ref
*qr
= qe
->ref
;
7154 /* Follow the references until
7155 a) They start to differ, in which case there is no error;
7156 you can deallocate a%b and a%c in a single statement
7157 b) Both of them stop, which is an error
7158 c) One of them stops, which is also an error. */
7161 if (pr
== NULL
&& qr
== NULL
)
7163 gfc_error ("Allocate-object at %L also appears at %L",
7164 &pe
->where
, &qe
->where
);
7167 else if (pr
!= NULL
&& qr
== NULL
)
7169 gfc_error ("Allocate-object at %L is subobject of"
7170 " object at %L", &pe
->where
, &qe
->where
);
7173 else if (pr
== NULL
&& qr
!= NULL
)
7175 gfc_error ("Allocate-object at %L is subobject of"
7176 " object at %L", &qe
->where
, &pe
->where
);
7179 /* Here, pr != NULL && qr != NULL */
7180 gcc_assert(pr
->type
== qr
->type
);
7181 if (pr
->type
== REF_ARRAY
)
7183 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7185 gcc_assert (qr
->type
== REF_ARRAY
);
7187 if (pr
->next
&& qr
->next
)
7190 gfc_array_ref
*par
= &(pr
->u
.ar
);
7191 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7193 for (i
=0; i
<par
->dimen
; i
++)
7195 if ((par
->start
[i
] != NULL
7196 || qar
->start
[i
] != NULL
)
7197 && gfc_dep_compare_expr (par
->start
[i
],
7198 qar
->start
[i
]) != 0)
7205 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7218 if (strcmp (fcn
, "ALLOCATE") == 0)
7220 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7221 resolve_allocate_expr (a
->expr
, code
);
7225 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7226 resolve_deallocate_expr (a
->expr
);
7231 /************ SELECT CASE resolution subroutines ************/
7233 /* Callback function for our mergesort variant. Determines interval
7234 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7235 op1 > op2. Assumes we're not dealing with the default case.
7236 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7237 There are nine situations to check. */
7240 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7244 if (op1
->low
== NULL
) /* op1 = (:L) */
7246 /* op2 = (:N), so overlap. */
7248 /* op2 = (M:) or (M:N), L < M */
7249 if (op2
->low
!= NULL
7250 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7253 else if (op1
->high
== NULL
) /* op1 = (K:) */
7255 /* op2 = (M:), so overlap. */
7257 /* op2 = (:N) or (M:N), K > N */
7258 if (op2
->high
!= NULL
7259 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7262 else /* op1 = (K:L) */
7264 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7265 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7267 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7268 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7270 else /* op2 = (M:N) */
7274 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7277 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7286 /* Merge-sort a double linked case list, detecting overlap in the
7287 process. LIST is the head of the double linked case list before it
7288 is sorted. Returns the head of the sorted list if we don't see any
7289 overlap, or NULL otherwise. */
7292 check_case_overlap (gfc_case
*list
)
7294 gfc_case
*p
, *q
, *e
, *tail
;
7295 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7297 /* If the passed list was empty, return immediately. */
7304 /* Loop unconditionally. The only exit from this loop is a return
7305 statement, when we've finished sorting the case list. */
7312 /* Count the number of merges we do in this pass. */
7315 /* Loop while there exists a merge to be done. */
7320 /* Count this merge. */
7323 /* Cut the list in two pieces by stepping INSIZE places
7324 forward in the list, starting from P. */
7327 for (i
= 0; i
< insize
; i
++)
7336 /* Now we have two lists. Merge them! */
7337 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7339 /* See from which the next case to merge comes from. */
7342 /* P is empty so the next case must come from Q. */
7347 else if (qsize
== 0 || q
== NULL
)
7356 cmp
= compare_cases (p
, q
);
7359 /* The whole case range for P is less than the
7367 /* The whole case range for Q is greater than
7368 the case range for P. */
7375 /* The cases overlap, or they are the same
7376 element in the list. Either way, we must
7377 issue an error and get the next case from P. */
7378 /* FIXME: Sort P and Q by line number. */
7379 gfc_error ("CASE label at %L overlaps with CASE "
7380 "label at %L", &p
->where
, &q
->where
);
7388 /* Add the next element to the merged list. */
7397 /* P has now stepped INSIZE places along, and so has Q. So
7398 they're the same. */
7403 /* If we have done only one merge or none at all, we've
7404 finished sorting the cases. */
7413 /* Otherwise repeat, merging lists twice the size. */
7419 /* Check to see if an expression is suitable for use in a CASE statement.
7420 Makes sure that all case expressions are scalar constants of the same
7421 type. Return false if anything is wrong. */
7424 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7426 if (e
== NULL
) return true;
7428 if (e
->ts
.type
!= case_expr
->ts
.type
)
7430 gfc_error ("Expression in CASE statement at %L must be of type %s",
7431 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7435 /* C805 (R808) For a given case-construct, each case-value shall be of
7436 the same type as case-expr. For character type, length differences
7437 are allowed, but the kind type parameters shall be the same. */
7439 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7441 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7442 &e
->where
, case_expr
->ts
.kind
);
7446 /* Convert the case value kind to that of case expression kind,
7449 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7450 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7454 gfc_error ("Expression in CASE statement at %L must be scalar",
7463 /* Given a completely parsed select statement, we:
7465 - Validate all expressions and code within the SELECT.
7466 - Make sure that the selection expression is not of the wrong type.
7467 - Make sure that no case ranges overlap.
7468 - Eliminate unreachable cases and unreachable code resulting from
7469 removing case labels.
7471 The standard does allow unreachable cases, e.g. CASE (5:3). But
7472 they are a hassle for code generation, and to prevent that, we just
7473 cut them out here. This is not necessary for overlapping cases
7474 because they are illegal and we never even try to generate code.
7476 We have the additional caveat that a SELECT construct could have
7477 been a computed GOTO in the source code. Fortunately we can fairly
7478 easily work around that here: The case_expr for a "real" SELECT CASE
7479 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7480 we have to do is make sure that the case_expr is a scalar integer
7484 resolve_select (gfc_code
*code
, bool select_type
)
7487 gfc_expr
*case_expr
;
7488 gfc_case
*cp
, *default_case
, *tail
, *head
;
7489 int seen_unreachable
;
7495 if (code
->expr1
== NULL
)
7497 /* This was actually a computed GOTO statement. */
7498 case_expr
= code
->expr2
;
7499 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7500 gfc_error ("Selection expression in computed GOTO statement "
7501 "at %L must be a scalar integer expression",
7504 /* Further checking is not necessary because this SELECT was built
7505 by the compiler, so it should always be OK. Just move the
7506 case_expr from expr2 to expr so that we can handle computed
7507 GOTOs as normal SELECTs from here on. */
7508 code
->expr1
= code
->expr2
;
7513 case_expr
= code
->expr1
;
7514 type
= case_expr
->ts
.type
;
7517 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7519 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7520 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7522 /* Punt. Going on here just produce more garbage error messages. */
7527 if (!select_type
&& case_expr
->rank
!= 0)
7529 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7530 "expression", &case_expr
->where
);
7536 /* Raise a warning if an INTEGER case value exceeds the range of
7537 the case-expr. Later, all expressions will be promoted to the
7538 largest kind of all case-labels. */
7540 if (type
== BT_INTEGER
)
7541 for (body
= code
->block
; body
; body
= body
->block
)
7542 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7545 && gfc_check_integer_range (cp
->low
->value
.integer
,
7546 case_expr
->ts
.kind
) != ARITH_OK
)
7547 gfc_warning ("Expression in CASE statement at %L is "
7548 "not in the range of %s", &cp
->low
->where
,
7549 gfc_typename (&case_expr
->ts
));
7552 && cp
->low
!= cp
->high
7553 && gfc_check_integer_range (cp
->high
->value
.integer
,
7554 case_expr
->ts
.kind
) != ARITH_OK
)
7555 gfc_warning ("Expression in CASE statement at %L is "
7556 "not in the range of %s", &cp
->high
->where
,
7557 gfc_typename (&case_expr
->ts
));
7560 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7561 of the SELECT CASE expression and its CASE values. Walk the lists
7562 of case values, and if we find a mismatch, promote case_expr to
7563 the appropriate kind. */
7565 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7567 for (body
= code
->block
; body
; body
= body
->block
)
7569 /* Walk the case label list. */
7570 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7572 /* Intercept the DEFAULT case. It does not have a kind. */
7573 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7576 /* Unreachable case ranges are discarded, so ignore. */
7577 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7578 && cp
->low
!= cp
->high
7579 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7583 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7584 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7586 if (cp
->high
!= NULL
7587 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7588 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7593 /* Assume there is no DEFAULT case. */
7594 default_case
= NULL
;
7599 for (body
= code
->block
; body
; body
= body
->block
)
7601 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7603 seen_unreachable
= 0;
7605 /* Walk the case label list, making sure that all case labels
7607 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7609 /* Count the number of cases in the whole construct. */
7612 /* Intercept the DEFAULT case. */
7613 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7615 if (default_case
!= NULL
)
7617 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7618 "by a second DEFAULT CASE at %L",
7619 &default_case
->where
, &cp
->where
);
7630 /* Deal with single value cases and case ranges. Errors are
7631 issued from the validation function. */
7632 if (!validate_case_label_expr (cp
->low
, case_expr
)
7633 || !validate_case_label_expr (cp
->high
, case_expr
))
7639 if (type
== BT_LOGICAL
7640 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7641 || cp
->low
!= cp
->high
))
7643 gfc_error ("Logical range in CASE statement at %L is not "
7644 "allowed", &cp
->low
->where
);
7649 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7652 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7653 if (value
& seen_logical
)
7655 gfc_error ("Constant logical value in CASE statement "
7656 "is repeated at %L",
7661 seen_logical
|= value
;
7664 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7665 && cp
->low
!= cp
->high
7666 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7668 if (gfc_option
.warn_surprising
)
7669 gfc_warning ("Range specification at %L can never "
7670 "be matched", &cp
->where
);
7672 cp
->unreachable
= 1;
7673 seen_unreachable
= 1;
7677 /* If the case range can be matched, it can also overlap with
7678 other cases. To make sure it does not, we put it in a
7679 double linked list here. We sort that with a merge sort
7680 later on to detect any overlapping cases. */
7684 head
->right
= head
->left
= NULL
;
7689 tail
->right
->left
= tail
;
7696 /* It there was a failure in the previous case label, give up
7697 for this case label list. Continue with the next block. */
7701 /* See if any case labels that are unreachable have been seen.
7702 If so, we eliminate them. This is a bit of a kludge because
7703 the case lists for a single case statement (label) is a
7704 single forward linked lists. */
7705 if (seen_unreachable
)
7707 /* Advance until the first case in the list is reachable. */
7708 while (body
->ext
.block
.case_list
!= NULL
7709 && body
->ext
.block
.case_list
->unreachable
)
7711 gfc_case
*n
= body
->ext
.block
.case_list
;
7712 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7714 gfc_free_case_list (n
);
7717 /* Strip all other unreachable cases. */
7718 if (body
->ext
.block
.case_list
)
7720 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7722 if (cp
->next
->unreachable
)
7724 gfc_case
*n
= cp
->next
;
7725 cp
->next
= cp
->next
->next
;
7727 gfc_free_case_list (n
);
7734 /* See if there were overlapping cases. If the check returns NULL,
7735 there was overlap. In that case we don't do anything. If head
7736 is non-NULL, we prepend the DEFAULT case. The sorted list can
7737 then used during code generation for SELECT CASE constructs with
7738 a case expression of a CHARACTER type. */
7741 head
= check_case_overlap (head
);
7743 /* Prepend the default_case if it is there. */
7744 if (head
!= NULL
&& default_case
)
7746 default_case
->left
= NULL
;
7747 default_case
->right
= head
;
7748 head
->left
= default_case
;
7752 /* Eliminate dead blocks that may be the result if we've seen
7753 unreachable case labels for a block. */
7754 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7756 if (body
->block
->ext
.block
.case_list
== NULL
)
7758 /* Cut the unreachable block from the code chain. */
7759 gfc_code
*c
= body
->block
;
7760 body
->block
= c
->block
;
7762 /* Kill the dead block, but not the blocks below it. */
7764 gfc_free_statements (c
);
7768 /* More than two cases is legal but insane for logical selects.
7769 Issue a warning for it. */
7770 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7772 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7777 /* Check if a derived type is extensible. */
7780 gfc_type_is_extensible (gfc_symbol
*sym
)
7782 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7783 || (sym
->attr
.is_class
7784 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7788 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7789 correct as well as possibly the array-spec. */
7792 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7796 gcc_assert (sym
->assoc
);
7797 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7799 /* If this is for SELECT TYPE, the target may not yet be set. In that
7800 case, return. Resolution will be called later manually again when
7802 target
= sym
->assoc
->target
;
7805 gcc_assert (!sym
->assoc
->dangling
);
7807 if (resolve_target
&& !gfc_resolve_expr (target
))
7810 /* For variable targets, we get some attributes from the target. */
7811 if (target
->expr_type
== EXPR_VARIABLE
)
7815 gcc_assert (target
->symtree
);
7816 tsym
= target
->symtree
->n
.sym
;
7818 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7819 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7821 sym
->attr
.target
= tsym
->attr
.target
7822 || gfc_expr_attr (target
).pointer
;
7825 /* Get type if this was not already set. Note that it can be
7826 some other type than the target in case this is a SELECT TYPE
7827 selector! So we must not update when the type is already there. */
7828 if (sym
->ts
.type
== BT_UNKNOWN
)
7829 sym
->ts
= target
->ts
;
7830 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7832 /* See if this is a valid association-to-variable. */
7833 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7834 && !gfc_has_vector_subscript (target
));
7836 /* Finally resolve if this is an array or not. */
7837 if (sym
->attr
.dimension
&& target
->rank
== 0)
7839 gfc_error ("Associate-name '%s' at %L is used as array",
7840 sym
->name
, &sym
->declared_at
);
7841 sym
->attr
.dimension
= 0;
7845 /* We cannot deal with class selectors that need temporaries. */
7846 if (target
->ts
.type
== BT_CLASS
7847 && gfc_ref_needs_temporary_p (target
->ref
))
7849 gfc_error ("CLASS selector at %L needs a temporary which is not "
7850 "yet implemented", &target
->where
);
7854 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7855 sym
->attr
.dimension
= 1;
7856 else if (target
->ts
.type
== BT_CLASS
)
7857 gfc_fix_class_refs (target
);
7859 /* The associate-name will have a correct type by now. Make absolutely
7860 sure that it has not picked up a dimension attribute. */
7861 if (sym
->ts
.type
== BT_CLASS
)
7862 sym
->attr
.dimension
= 0;
7864 if (sym
->attr
.dimension
)
7866 sym
->as
= gfc_get_array_spec ();
7867 sym
->as
->rank
= target
->rank
;
7868 sym
->as
->type
= AS_DEFERRED
;
7870 /* Target must not be coindexed, thus the associate-variable
7872 sym
->as
->corank
= 0;
7875 /* Mark this as an associate variable. */
7876 sym
->attr
.associate_var
= 1;
7878 /* If the target is a good class object, so is the associate variable. */
7879 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7880 sym
->attr
.class_ok
= 1;
7884 /* Resolve a SELECT TYPE statement. */
7887 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7889 gfc_symbol
*selector_type
;
7890 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7891 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7894 char name
[GFC_MAX_SYMBOL_LEN
];
7899 ns
= code
->ext
.block
.ns
;
7902 /* Check for F03:C813. */
7903 if (code
->expr1
->ts
.type
!= BT_CLASS
7904 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7906 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7907 "at %L", &code
->loc
);
7911 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7916 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7917 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7918 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7920 /* F2008: C803 The selector expression must not be coindexed. */
7921 if (gfc_is_coindexed (code
->expr2
))
7923 gfc_error ("Selector at %L must not be coindexed",
7924 &code
->expr2
->where
);
7931 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7933 if (gfc_is_coindexed (code
->expr1
))
7935 gfc_error ("Selector at %L must not be coindexed",
7936 &code
->expr1
->where
);
7941 /* Loop over TYPE IS / CLASS IS cases. */
7942 for (body
= code
->block
; body
; body
= body
->block
)
7944 c
= body
->ext
.block
.case_list
;
7946 /* Check F03:C815. */
7947 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7948 && !selector_type
->attr
.unlimited_polymorphic
7949 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7951 gfc_error ("Derived type '%s' at %L must be extensible",
7952 c
->ts
.u
.derived
->name
, &c
->where
);
7957 /* Check F03:C816. */
7958 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
7959 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
7960 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
7962 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7963 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7964 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7966 gfc_error ("Unexpected intrinsic type '%s' at %L",
7967 gfc_basic_typename (c
->ts
.type
), &c
->where
);
7972 /* Check F03:C814. */
7973 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
7975 gfc_error ("The type-spec at %L shall specify that each length "
7976 "type parameter is assumed", &c
->where
);
7981 /* Intercept the DEFAULT case. */
7982 if (c
->ts
.type
== BT_UNKNOWN
)
7984 /* Check F03:C818. */
7987 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7988 "by a second DEFAULT CASE at %L",
7989 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7994 default_case
= body
;
8001 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8002 target if present. If there are any EXIT statements referring to the
8003 SELECT TYPE construct, this is no problem because the gfc_code
8004 reference stays the same and EXIT is equally possible from the BLOCK
8005 it is changed to. */
8006 code
->op
= EXEC_BLOCK
;
8009 gfc_association_list
* assoc
;
8011 assoc
= gfc_get_association_list ();
8012 assoc
->st
= code
->expr1
->symtree
;
8013 assoc
->target
= gfc_copy_expr (code
->expr2
);
8014 assoc
->target
->where
= code
->expr2
->where
;
8015 /* assoc->variable will be set by resolve_assoc_var. */
8017 code
->ext
.block
.assoc
= assoc
;
8018 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8020 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8023 code
->ext
.block
.assoc
= NULL
;
8025 /* Add EXEC_SELECT to switch on type. */
8026 new_st
= gfc_get_code (code
->op
);
8027 new_st
->expr1
= code
->expr1
;
8028 new_st
->expr2
= code
->expr2
;
8029 new_st
->block
= code
->block
;
8030 code
->expr1
= code
->expr2
= NULL
;
8035 ns
->code
->next
= new_st
;
8037 code
->op
= EXEC_SELECT
;
8039 gfc_add_vptr_component (code
->expr1
);
8040 gfc_add_hash_component (code
->expr1
);
8042 /* Loop over TYPE IS / CLASS IS cases. */
8043 for (body
= code
->block
; body
; body
= body
->block
)
8045 c
= body
->ext
.block
.case_list
;
8047 if (c
->ts
.type
== BT_DERIVED
)
8048 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8049 c
->ts
.u
.derived
->hash_value
);
8050 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8055 ivtab
= gfc_find_vtab (&c
->ts
);
8056 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8057 e
= CLASS_DATA (ivtab
)->initializer
;
8058 c
->low
= c
->high
= gfc_copy_expr (e
);
8061 else if (c
->ts
.type
== BT_UNKNOWN
)
8064 /* Associate temporary to selector. This should only be done
8065 when this case is actually true, so build a new ASSOCIATE
8066 that does precisely this here (instead of using the
8069 if (c
->ts
.type
== BT_CLASS
)
8070 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8071 else if (c
->ts
.type
== BT_DERIVED
)
8072 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8073 else if (c
->ts
.type
== BT_CHARACTER
)
8075 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8076 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8077 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8078 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8079 charlen
, c
->ts
.kind
);
8082 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8085 st
= gfc_find_symtree (ns
->sym_root
, name
);
8086 gcc_assert (st
->n
.sym
->assoc
);
8087 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8088 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8089 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8090 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8092 new_st
= gfc_get_code (EXEC_BLOCK
);
8093 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8094 new_st
->ext
.block
.ns
->code
= body
->next
;
8095 body
->next
= new_st
;
8097 /* Chain in the new list only if it is marked as dangling. Otherwise
8098 there is a CASE label overlap and this is already used. Just ignore,
8099 the error is diagnosed elsewhere. */
8100 if (st
->n
.sym
->assoc
->dangling
)
8102 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8103 st
->n
.sym
->assoc
->dangling
= 0;
8106 resolve_assoc_var (st
->n
.sym
, false);
8109 /* Take out CLASS IS cases for separate treatment. */
8111 while (body
&& body
->block
)
8113 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8115 /* Add to class_is list. */
8116 if (class_is
== NULL
)
8118 class_is
= body
->block
;
8123 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8124 tail
->block
= body
->block
;
8127 /* Remove from EXEC_SELECT list. */
8128 body
->block
= body
->block
->block
;
8141 /* Add a default case to hold the CLASS IS cases. */
8142 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8143 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8145 tail
->ext
.block
.case_list
= gfc_get_case ();
8146 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8148 default_case
= tail
;
8151 /* More than one CLASS IS block? */
8152 if (class_is
->block
)
8156 /* Sort CLASS IS blocks by extension level. */
8160 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8163 /* F03:C817 (check for doubles). */
8164 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8165 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8167 gfc_error ("Double CLASS IS block in SELECT TYPE "
8169 &c2
->ext
.block
.case_list
->where
);
8172 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8173 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8176 (*c1
)->block
= c2
->block
;
8186 /* Generate IF chain. */
8187 if_st
= gfc_get_code (EXEC_IF
);
8189 for (body
= class_is
; body
; body
= body
->block
)
8191 new_st
->block
= gfc_get_code (EXEC_IF
);
8192 new_st
= new_st
->block
;
8193 /* Set up IF condition: Call _gfortran_is_extension_of. */
8194 new_st
->expr1
= gfc_get_expr ();
8195 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8196 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8197 new_st
->expr1
->ts
.kind
= 4;
8198 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8199 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8200 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8201 /* Set up arguments. */
8202 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8203 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8204 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8205 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8206 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8207 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8208 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8209 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8210 new_st
->next
= body
->next
;
8212 if (default_case
->next
)
8214 new_st
->block
= gfc_get_code (EXEC_IF
);
8215 new_st
= new_st
->block
;
8216 new_st
->next
= default_case
->next
;
8219 /* Replace CLASS DEFAULT code by the IF chain. */
8220 default_case
->next
= if_st
;
8223 /* Resolve the internal code. This can not be done earlier because
8224 it requires that the sym->assoc of selectors is set already. */
8225 gfc_current_ns
= ns
;
8226 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8227 gfc_current_ns
= old_ns
;
8229 resolve_select (code
, true);
8233 /* Resolve a transfer statement. This is making sure that:
8234 -- a derived type being transferred has only non-pointer components
8235 -- a derived type being transferred doesn't have private components, unless
8236 it's being transferred from the module where the type was defined
8237 -- we're not trying to transfer a whole assumed size array. */
8240 resolve_transfer (gfc_code
*code
)
8249 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8250 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8251 exp
= exp
->value
.op
.op1
;
8253 if (exp
&& exp
->expr_type
== EXPR_NULL
8256 gfc_error ("Invalid context for NULL () intrinsic at %L",
8261 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8262 && exp
->expr_type
!= EXPR_FUNCTION
))
8265 /* If we are reading, the variable will be changed. Note that
8266 code->ext.dt may be NULL if the TRANSFER is related to
8267 an INQUIRE statement -- but in this case, we are not reading, either. */
8268 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8269 && !gfc_check_vardef_context (exp
, false, false, false,
8273 sym
= exp
->symtree
->n
.sym
;
8276 /* Go to actual component transferred. */
8277 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8278 if (ref
->type
== REF_COMPONENT
)
8279 ts
= &ref
->u
.c
.component
->ts
;
8281 if (ts
->type
== BT_CLASS
)
8283 /* FIXME: Test for defined input/output. */
8284 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8285 "it is processed by a defined input/output procedure",
8290 if (ts
->type
== BT_DERIVED
)
8292 /* Check that transferred derived type doesn't contain POINTER
8294 if (ts
->u
.derived
->attr
.pointer_comp
)
8296 gfc_error ("Data transfer element at %L cannot have POINTER "
8297 "components unless it is processed by a defined "
8298 "input/output procedure", &code
->loc
);
8303 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8305 gfc_error ("Data transfer element at %L cannot have "
8306 "procedure pointer components", &code
->loc
);
8310 if (ts
->u
.derived
->attr
.alloc_comp
)
8312 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8313 "components unless it is processed by a defined "
8314 "input/output procedure", &code
->loc
);
8318 /* C_PTR and C_FUNPTR have private components which means they can not
8319 be printed. However, if -std=gnu and not -pedantic, allow
8320 the component to be printed to help debugging. */
8321 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8323 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8324 "cannot have PRIVATE components", &code
->loc
))
8327 else if (derived_inaccessible (ts
->u
.derived
))
8329 gfc_error ("Data transfer element at %L cannot have "
8330 "PRIVATE components",&code
->loc
);
8335 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8336 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8338 gfc_error ("Data transfer element at %L cannot be a full reference to "
8339 "an assumed-size array", &code
->loc
);
8345 /*********** Toplevel code resolution subroutines ***********/
8347 /* Find the set of labels that are reachable from this block. We also
8348 record the last statement in each block. */
8351 find_reachable_labels (gfc_code
*block
)
8358 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8360 /* Collect labels in this block. We don't keep those corresponding
8361 to END {IF|SELECT}, these are checked in resolve_branch by going
8362 up through the code_stack. */
8363 for (c
= block
; c
; c
= c
->next
)
8365 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8366 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8369 /* Merge with labels from parent block. */
8372 gcc_assert (cs_base
->prev
->reachable_labels
);
8373 bitmap_ior_into (cs_base
->reachable_labels
,
8374 cs_base
->prev
->reachable_labels
);
8380 resolve_lock_unlock (gfc_code
*code
)
8382 if (code
->expr1
->ts
.type
!= BT_DERIVED
8383 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8384 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8385 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8386 || code
->expr1
->rank
!= 0
8387 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8388 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8389 &code
->expr1
->where
);
8393 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8394 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8395 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8396 &code
->expr2
->where
);
8399 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8400 _("STAT variable")))
8405 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8406 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8407 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8408 &code
->expr3
->where
);
8411 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8412 _("ERRMSG variable")))
8415 /* Check ACQUIRED_LOCK. */
8417 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8418 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8419 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8420 "variable", &code
->expr4
->where
);
8423 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8424 _("ACQUIRED_LOCK variable")))
8430 resolve_sync (gfc_code
*code
)
8432 /* Check imageset. The * case matches expr1 == NULL. */
8435 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8436 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8437 "INTEGER expression", &code
->expr1
->where
);
8438 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8439 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8440 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8441 &code
->expr1
->where
);
8442 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8443 && gfc_simplify_expr (code
->expr1
, 0))
8445 gfc_constructor
*cons
;
8446 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8447 for (; cons
; cons
= gfc_constructor_next (cons
))
8448 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8449 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8450 gfc_error ("Imageset argument at %L must between 1 and "
8451 "num_images()", &cons
->expr
->where
);
8457 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8458 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8459 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8460 &code
->expr2
->where
);
8464 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8465 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8466 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8467 &code
->expr3
->where
);
8471 /* Given a branch to a label, see if the branch is conforming.
8472 The code node describes where the branch is located. */
8475 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8482 /* Step one: is this a valid branching target? */
8484 if (label
->defined
== ST_LABEL_UNKNOWN
)
8486 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8491 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8493 gfc_error ("Statement at %L is not a valid branch target statement "
8494 "for the branch statement at %L", &label
->where
, &code
->loc
);
8498 /* Step two: make sure this branch is not a branch to itself ;-) */
8500 if (code
->here
== label
)
8502 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8506 /* Step three: See if the label is in the same block as the
8507 branching statement. The hard work has been done by setting up
8508 the bitmap reachable_labels. */
8510 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8512 /* Check now whether there is a CRITICAL construct; if so, check
8513 whether the label is still visible outside of the CRITICAL block,
8514 which is invalid. */
8515 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8517 if (stack
->current
->op
== EXEC_CRITICAL
8518 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8519 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8520 "label at %L", &code
->loc
, &label
->where
);
8521 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8522 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8523 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8524 "for label at %L", &code
->loc
, &label
->where
);
8530 /* Step four: If we haven't found the label in the bitmap, it may
8531 still be the label of the END of the enclosing block, in which
8532 case we find it by going up the code_stack. */
8534 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8536 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8538 if (stack
->current
->op
== EXEC_CRITICAL
)
8540 /* Note: A label at END CRITICAL does not leave the CRITICAL
8541 construct as END CRITICAL is still part of it. */
8542 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8543 " at %L", &code
->loc
, &label
->where
);
8546 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8548 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8549 "label at %L", &code
->loc
, &label
->where
);
8556 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8560 /* The label is not in an enclosing block, so illegal. This was
8561 allowed in Fortran 66, so we allow it as extension. No
8562 further checks are necessary in this case. */
8563 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8564 "as the GOTO statement at %L", &label
->where
,
8570 /* Check whether EXPR1 has the same shape as EXPR2. */
8573 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8575 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8576 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8577 bool result
= false;
8580 /* Compare the rank. */
8581 if (expr1
->rank
!= expr2
->rank
)
8584 /* Compare the size of each dimension. */
8585 for (i
=0; i
<expr1
->rank
; i
++)
8587 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8590 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8593 if (mpz_cmp (shape
[i
], shape2
[i
]))
8597 /* When either of the two expression is an assumed size array, we
8598 ignore the comparison of dimension sizes. */
8603 gfc_clear_shape (shape
, i
);
8604 gfc_clear_shape (shape2
, i
);
8609 /* Check whether a WHERE assignment target or a WHERE mask expression
8610 has the same shape as the outmost WHERE mask expression. */
8613 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8619 cblock
= code
->block
;
8621 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8622 In case of nested WHERE, only the outmost one is stored. */
8623 if (mask
== NULL
) /* outmost WHERE */
8625 else /* inner WHERE */
8632 /* Check if the mask-expr has a consistent shape with the
8633 outmost WHERE mask-expr. */
8634 if (!resolve_where_shape (cblock
->expr1
, e
))
8635 gfc_error ("WHERE mask at %L has inconsistent shape",
8636 &cblock
->expr1
->where
);
8639 /* the assignment statement of a WHERE statement, or the first
8640 statement in where-body-construct of a WHERE construct */
8641 cnext
= cblock
->next
;
8646 /* WHERE assignment statement */
8649 /* Check shape consistent for WHERE assignment target. */
8650 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8651 gfc_error ("WHERE assignment target at %L has "
8652 "inconsistent shape", &cnext
->expr1
->where
);
8656 case EXEC_ASSIGN_CALL
:
8657 resolve_call (cnext
);
8658 if (!cnext
->resolved_sym
->attr
.elemental
)
8659 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8660 &cnext
->ext
.actual
->expr
->where
);
8663 /* WHERE or WHERE construct is part of a where-body-construct */
8665 resolve_where (cnext
, e
);
8669 gfc_error ("Unsupported statement inside WHERE at %L",
8672 /* the next statement within the same where-body-construct */
8673 cnext
= cnext
->next
;
8675 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8676 cblock
= cblock
->block
;
8681 /* Resolve assignment in FORALL construct.
8682 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8683 FORALL index variables. */
8686 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8690 for (n
= 0; n
< nvar
; n
++)
8692 gfc_symbol
*forall_index
;
8694 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8696 /* Check whether the assignment target is one of the FORALL index
8698 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8699 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8700 gfc_error ("Assignment to a FORALL index variable at %L",
8701 &code
->expr1
->where
);
8704 /* If one of the FORALL index variables doesn't appear in the
8705 assignment variable, then there could be a many-to-one
8706 assignment. Emit a warning rather than an error because the
8707 mask could be resolving this problem. */
8708 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8709 gfc_warning ("The FORALL with index '%s' is not used on the "
8710 "left side of the assignment at %L and so might "
8711 "cause multiple assignment to this object",
8712 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8718 /* Resolve WHERE statement in FORALL construct. */
8721 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8722 gfc_expr
**var_expr
)
8727 cblock
= code
->block
;
8730 /* the assignment statement of a WHERE statement, or the first
8731 statement in where-body-construct of a WHERE construct */
8732 cnext
= cblock
->next
;
8737 /* WHERE assignment statement */
8739 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8742 /* WHERE operator assignment statement */
8743 case EXEC_ASSIGN_CALL
:
8744 resolve_call (cnext
);
8745 if (!cnext
->resolved_sym
->attr
.elemental
)
8746 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8747 &cnext
->ext
.actual
->expr
->where
);
8750 /* WHERE or WHERE construct is part of a where-body-construct */
8752 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8756 gfc_error ("Unsupported statement inside WHERE at %L",
8759 /* the next statement within the same where-body-construct */
8760 cnext
= cnext
->next
;
8762 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8763 cblock
= cblock
->block
;
8768 /* Traverse the FORALL body to check whether the following errors exist:
8769 1. For assignment, check if a many-to-one assignment happens.
8770 2. For WHERE statement, check the WHERE body to see if there is any
8771 many-to-one assignment. */
8774 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8778 c
= code
->block
->next
;
8784 case EXEC_POINTER_ASSIGN
:
8785 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8788 case EXEC_ASSIGN_CALL
:
8792 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8793 there is no need to handle it here. */
8797 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8802 /* The next statement in the FORALL body. */
8808 /* Counts the number of iterators needed inside a forall construct, including
8809 nested forall constructs. This is used to allocate the needed memory
8810 in gfc_resolve_forall. */
8813 gfc_count_forall_iterators (gfc_code
*code
)
8815 int max_iters
, sub_iters
, current_iters
;
8816 gfc_forall_iterator
*fa
;
8818 gcc_assert(code
->op
== EXEC_FORALL
);
8822 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8825 code
= code
->block
->next
;
8829 if (code
->op
== EXEC_FORALL
)
8831 sub_iters
= gfc_count_forall_iterators (code
);
8832 if (sub_iters
> max_iters
)
8833 max_iters
= sub_iters
;
8838 return current_iters
+ max_iters
;
8842 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8843 gfc_resolve_forall_body to resolve the FORALL body. */
8846 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8848 static gfc_expr
**var_expr
;
8849 static int total_var
= 0;
8850 static int nvar
= 0;
8852 gfc_forall_iterator
*fa
;
8857 /* Start to resolve a FORALL construct */
8858 if (forall_save
== 0)
8860 /* Count the total number of FORALL index in the nested FORALL
8861 construct in order to allocate the VAR_EXPR with proper size. */
8862 total_var
= gfc_count_forall_iterators (code
);
8864 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8865 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8868 /* The information about FORALL iterator, including FORALL index start, end
8869 and stride. The FORALL index can not appear in start, end or stride. */
8870 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8872 /* Check if any outer FORALL index name is the same as the current
8874 for (i
= 0; i
< nvar
; i
++)
8876 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8878 gfc_error ("An outer FORALL construct already has an index "
8879 "with this name %L", &fa
->var
->where
);
8883 /* Record the current FORALL index. */
8884 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8888 /* No memory leak. */
8889 gcc_assert (nvar
<= total_var
);
8892 /* Resolve the FORALL body. */
8893 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8895 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8896 gfc_resolve_blocks (code
->block
, ns
);
8900 /* Free only the VAR_EXPRs allocated in this frame. */
8901 for (i
= nvar
; i
< tmp
; i
++)
8902 gfc_free_expr (var_expr
[i
]);
8906 /* We are in the outermost FORALL construct. */
8907 gcc_assert (forall_save
== 0);
8909 /* VAR_EXPR is not needed any more. */
8916 /* Resolve a BLOCK construct statement. */
8919 resolve_block_construct (gfc_code
* code
)
8921 /* Resolve the BLOCK's namespace. */
8922 gfc_resolve (code
->ext
.block
.ns
);
8924 /* For an ASSOCIATE block, the associations (and their targets) are already
8925 resolved during resolve_symbol. */
8929 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8932 static void resolve_code (gfc_code
*, gfc_namespace
*);
8935 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8939 for (; b
; b
= b
->block
)
8941 t
= gfc_resolve_expr (b
->expr1
);
8942 if (!gfc_resolve_expr (b
->expr2
))
8948 if (t
&& b
->expr1
!= NULL
8949 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8950 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8957 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8958 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8963 resolve_branch (b
->label1
, b
);
8967 resolve_block_construct (b
);
8971 case EXEC_SELECT_TYPE
:
8975 case EXEC_DO_CONCURRENT
:
8983 case EXEC_OMP_ATOMIC
:
8984 case EXEC_OMP_CRITICAL
:
8986 case EXEC_OMP_MASTER
:
8987 case EXEC_OMP_ORDERED
:
8988 case EXEC_OMP_PARALLEL
:
8989 case EXEC_OMP_PARALLEL_DO
:
8990 case EXEC_OMP_PARALLEL_SECTIONS
:
8991 case EXEC_OMP_PARALLEL_WORKSHARE
:
8992 case EXEC_OMP_SECTIONS
:
8993 case EXEC_OMP_SINGLE
:
8995 case EXEC_OMP_TASKWAIT
:
8996 case EXEC_OMP_TASKYIELD
:
8997 case EXEC_OMP_WORKSHARE
:
9001 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9004 resolve_code (b
->next
, ns
);
9009 /* Does everything to resolve an ordinary assignment. Returns true
9010 if this is an interface assignment. */
9012 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9021 symbol_attribute attr
;
9023 if (gfc_extend_assign (code
, ns
))
9027 if (code
->op
== EXEC_ASSIGN_CALL
)
9029 lhs
= code
->ext
.actual
->expr
;
9030 rhsptr
= &code
->ext
.actual
->next
->expr
;
9034 gfc_actual_arglist
* args
;
9035 gfc_typebound_proc
* tbp
;
9037 gcc_assert (code
->op
== EXEC_COMPCALL
);
9039 args
= code
->expr1
->value
.compcall
.actual
;
9041 rhsptr
= &args
->next
->expr
;
9043 tbp
= code
->expr1
->value
.compcall
.tbp
;
9044 gcc_assert (!tbp
->is_generic
);
9047 /* Make a temporary rhs when there is a default initializer
9048 and rhs is the same symbol as the lhs. */
9049 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9050 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9051 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9052 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9053 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9062 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9063 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9067 /* Handle the case of a BOZ literal on the RHS. */
9068 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9071 if (gfc_option
.warn_surprising
)
9072 gfc_warning ("BOZ literal at %L is bitwise transferred "
9073 "non-integer symbol '%s'", &code
->loc
,
9074 lhs
->symtree
->n
.sym
->name
);
9076 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9078 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9080 if (rc
== ARITH_UNDERFLOW
)
9081 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9082 ". This check can be disabled with the option "
9083 "-fno-range-check", &rhs
->where
);
9084 else if (rc
== ARITH_OVERFLOW
)
9085 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9086 ". This check can be disabled with the option "
9087 "-fno-range-check", &rhs
->where
);
9088 else if (rc
== ARITH_NAN
)
9089 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9090 ". This check can be disabled with the option "
9091 "-fno-range-check", &rhs
->where
);
9096 if (lhs
->ts
.type
== BT_CHARACTER
9097 && gfc_option
.warn_character_truncation
)
9099 if (lhs
->ts
.u
.cl
!= NULL
9100 && lhs
->ts
.u
.cl
->length
!= NULL
9101 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9102 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9104 if (rhs
->expr_type
== EXPR_CONSTANT
)
9105 rlen
= rhs
->value
.character
.length
;
9107 else if (rhs
->ts
.u
.cl
!= NULL
9108 && rhs
->ts
.u
.cl
->length
!= NULL
9109 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9110 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9112 if (rlen
&& llen
&& rlen
> llen
)
9113 gfc_warning_now ("CHARACTER expression will be truncated "
9114 "in assignment (%d/%d) at %L",
9115 llen
, rlen
, &code
->loc
);
9118 /* Ensure that a vector index expression for the lvalue is evaluated
9119 to a temporary if the lvalue symbol is referenced in it. */
9122 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9123 if (ref
->type
== REF_ARRAY
)
9125 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9126 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9127 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9128 ref
->u
.ar
.start
[n
]))
9130 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9134 if (gfc_pure (NULL
))
9136 if (lhs
->ts
.type
== BT_DERIVED
9137 && lhs
->expr_type
== EXPR_VARIABLE
9138 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9139 && rhs
->expr_type
== EXPR_VARIABLE
9140 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9141 || gfc_is_coindexed (rhs
)))
9144 if (gfc_is_coindexed (rhs
))
9145 gfc_error ("Coindexed expression at %L is assigned to "
9146 "a derived type variable with a POINTER "
9147 "component in a PURE procedure",
9150 gfc_error ("The impure variable at %L is assigned to "
9151 "a derived type variable with a POINTER "
9152 "component in a PURE procedure (12.6)",
9157 /* Fortran 2008, C1283. */
9158 if (gfc_is_coindexed (lhs
))
9160 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9161 "procedure", &rhs
->where
);
9166 if (gfc_implicit_pure (NULL
))
9168 if (lhs
->expr_type
== EXPR_VARIABLE
9169 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9170 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9171 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9173 if (lhs
->ts
.type
== BT_DERIVED
9174 && lhs
->expr_type
== EXPR_VARIABLE
9175 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9176 && rhs
->expr_type
== EXPR_VARIABLE
9177 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9178 || gfc_is_coindexed (rhs
)))
9179 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9181 /* Fortran 2008, C1283. */
9182 if (gfc_is_coindexed (lhs
))
9183 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9186 /* F2008, 7.2.1.2. */
9187 attr
= gfc_expr_attr (lhs
);
9188 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9190 if (attr
.codimension
)
9192 gfc_error ("Assignment to polymorphic coarray at %L is not "
9193 "permitted", &lhs
->where
);
9196 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9197 "polymorphic variable at %L", &lhs
->where
))
9199 if (!gfc_option
.flag_realloc_lhs
)
9201 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9202 "requires -frealloc-lhs", &lhs
->where
);
9206 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9207 "is not yet supported", &lhs
->where
);
9210 else if (lhs
->ts
.type
== BT_CLASS
)
9212 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9213 "assignment at %L - check that there is a matching specific "
9214 "subroutine for '=' operator", &lhs
->where
);
9218 /* F2008, Section 7.2.1.2. */
9219 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9221 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9222 "component in assignment at %L", &lhs
->where
);
9226 gfc_check_assign (lhs
, rhs
, 1);
9231 /* Add a component reference onto an expression. */
9234 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9239 ref
= &((*ref
)->next
);
9240 *ref
= gfc_get_ref ();
9241 (*ref
)->type
= REF_COMPONENT
;
9242 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9243 (*ref
)->u
.c
.component
= c
;
9246 /* Add a full array ref, as necessary. */
9249 gfc_add_full_array_ref (e
, c
->as
);
9250 e
->rank
= c
->as
->rank
;
9255 /* Build an assignment. Keep the argument 'op' for future use, so that
9256 pointer assignments can be made. */
9259 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9260 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9262 gfc_code
*this_code
;
9264 this_code
= gfc_get_code (op
);
9265 this_code
->next
= NULL
;
9266 this_code
->expr1
= gfc_copy_expr (expr1
);
9267 this_code
->expr2
= gfc_copy_expr (expr2
);
9268 this_code
->loc
= loc
;
9271 add_comp_ref (this_code
->expr1
, comp1
);
9272 add_comp_ref (this_code
->expr2
, comp2
);
9279 /* Makes a temporary variable expression based on the characteristics of
9280 a given variable expression. */
9283 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9285 static int serial
= 0;
9286 char name
[GFC_MAX_SYMBOL_LEN
];
9289 gfc_array_ref
*aref
;
9292 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9293 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9294 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9300 /* This function could be expanded to support other expression type
9301 but this is not needed here. */
9302 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9304 /* Obtain the arrayspec for the temporary. */
9307 aref
= gfc_find_array_ref (e
);
9308 if (e
->expr_type
== EXPR_VARIABLE
9309 && e
->symtree
->n
.sym
->as
== aref
->as
)
9313 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9314 if (ref
->type
== REF_COMPONENT
9315 && ref
->u
.c
.component
->as
== aref
->as
)
9323 /* Add the attributes and the arrayspec to the temporary. */
9324 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9325 tmp
->n
.sym
->attr
.function
= 0;
9326 tmp
->n
.sym
->attr
.result
= 0;
9327 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9331 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9334 if (as
->type
== AS_DEFERRED
)
9335 tmp
->n
.sym
->attr
.allocatable
= 1;
9338 tmp
->n
.sym
->attr
.dimension
= 0;
9340 gfc_set_sym_referenced (tmp
->n
.sym
);
9341 gfc_commit_symbol (tmp
->n
.sym
);
9342 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9344 /* Should the lhs be a section, use its array ref for the
9345 temporary expression. */
9346 if (aref
&& aref
->type
!= AR_FULL
)
9348 gfc_free_ref_list (e
->ref
);
9349 e
->ref
= gfc_copy_ref (ref
);
9355 /* Add one line of code to the code chain, making sure that 'head' and
9356 'tail' are appropriately updated. */
9359 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9361 gcc_assert (this_code
);
9363 *head
= *tail
= *this_code
;
9365 *tail
= gfc_append_code (*tail
, *this_code
);
9370 /* Counts the potential number of part array references that would
9371 result from resolution of typebound defined assignments. */
9374 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9377 int c_depth
= 0, t_depth
;
9379 for (c
= derived
->components
; c
; c
= c
->next
)
9381 if ((c
->ts
.type
!= BT_DERIVED
9383 || c
->attr
.allocatable
9384 || c
->attr
.proc_pointer_comp
9385 || c
->attr
.class_pointer
9386 || c
->attr
.proc_pointer
)
9387 && !c
->attr
.defined_assign_comp
)
9390 if (c
->as
&& c_depth
== 0)
9393 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9394 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9399 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9401 return depth
+ c_depth
;
9405 /* Implement 7.2.1.3 of the F08 standard:
9406 "An intrinsic assignment where the variable is of derived type is
9407 performed as if each component of the variable were assigned from the
9408 corresponding component of expr using pointer assignment (7.2.2) for
9409 each pointer component, defined assignment for each nonpointer
9410 nonallocatable component of a type that has a type-bound defined
9411 assignment consistent with the component, intrinsic assignment for
9412 each other nonpointer nonallocatable component, ..."
9414 The pointer assignments are taken care of by the intrinsic
9415 assignment of the structure itself. This function recursively adds
9416 defined assignments where required. The recursion is accomplished
9417 by calling resolve_code.
9419 When the lhs in a defined assignment has intent INOUT, we need a
9420 temporary for the lhs. In pseudo-code:
9422 ! Only call function lhs once.
9423 if (lhs is not a constant or an variable)
9426 ! Do the intrinsic assignment
9428 ! Now do the defined assignments
9429 do over components with typebound defined assignment [%cmp]
9430 #if one component's assignment procedure is INOUT
9432 #if expr2 non-variable
9438 t1%cmp {defined=} expr2%cmp
9444 expr1%cmp {defined=} expr2%cmp
9448 /* The temporary assignments have to be put on top of the additional
9449 code to avoid the result being changed by the intrinsic assignment.
9451 static int component_assignment_level
= 0;
9452 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9455 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9457 gfc_component
*comp1
, *comp2
;
9458 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9460 int error_count
, depth
;
9462 gfc_get_errors (NULL
, &error_count
);
9464 /* Filter out continuing processing after an error. */
9466 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9467 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9470 /* TODO: Handle more than one part array reference in assignments. */
9471 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9472 (*code
)->expr1
->rank
? 1 : 0);
9475 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9476 "done because multiple part array references would "
9477 "occur in intermediate expressions.", &(*code
)->loc
);
9481 component_assignment_level
++;
9483 /* Create a temporary so that functions get called only once. */
9484 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9485 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9489 /* Assign the rhs to the temporary. */
9490 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9491 this_code
= build_assignment (EXEC_ASSIGN
,
9492 tmp_expr
, (*code
)->expr2
,
9493 NULL
, NULL
, (*code
)->loc
);
9494 /* Add the code and substitute the rhs expression. */
9495 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9496 gfc_free_expr ((*code
)->expr2
);
9497 (*code
)->expr2
= tmp_expr
;
9500 /* Do the intrinsic assignment. This is not needed if the lhs is one
9501 of the temporaries generated here, since the intrinsic assignment
9502 to the final result already does this. */
9503 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9505 this_code
= build_assignment (EXEC_ASSIGN
,
9506 (*code
)->expr1
, (*code
)->expr2
,
9507 NULL
, NULL
, (*code
)->loc
);
9508 add_code_to_chain (&this_code
, &head
, &tail
);
9511 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9512 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9515 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9519 /* The intrinsic assignment does the right thing for pointers
9520 of all kinds and allocatable components. */
9521 if (comp1
->ts
.type
!= BT_DERIVED
9522 || comp1
->attr
.pointer
9523 || comp1
->attr
.allocatable
9524 || comp1
->attr
.proc_pointer_comp
9525 || comp1
->attr
.class_pointer
9526 || comp1
->attr
.proc_pointer
)
9529 /* Make an assigment for this component. */
9530 this_code
= build_assignment (EXEC_ASSIGN
,
9531 (*code
)->expr1
, (*code
)->expr2
,
9532 comp1
, comp2
, (*code
)->loc
);
9534 /* Convert the assignment if there is a defined assignment for
9535 this type. Otherwise, using the call from resolve_code,
9536 recurse into its components. */
9537 resolve_code (this_code
, ns
);
9539 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9541 gfc_formal_arglist
*dummy_args
;
9543 /* Check that there is a typebound defined assignment. If not,
9544 then this must be a module defined assignment. We cannot
9545 use the defined_assign_comp attribute here because it must
9546 be this derived type that has the defined assignment and not
9548 if (!(comp1
->ts
.u
.derived
->f2k_derived
9549 && comp1
->ts
.u
.derived
->f2k_derived
9550 ->tb_op
[INTRINSIC_ASSIGN
]))
9552 gfc_free_statements (this_code
);
9557 /* If the first argument of the subroutine has intent INOUT
9558 a temporary must be generated and used instead. */
9559 rsym
= this_code
->resolved_sym
;
9560 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9562 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9564 gfc_code
*temp_code
;
9567 /* Build the temporary required for the assignment and put
9568 it at the head of the generated code. */
9571 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9572 temp_code
= build_assignment (EXEC_ASSIGN
,
9574 NULL
, NULL
, (*code
)->loc
);
9576 /* For allocatable LHS, check whether it is allocated. Note
9577 that allocatable components with defined assignment are
9578 not yet support. See PR 57696. */
9579 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9583 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9584 block
= gfc_get_code (EXEC_IF
);
9585 block
->block
= gfc_get_code (EXEC_IF
);
9587 = gfc_build_intrinsic_call (ns
,
9588 GFC_ISYM_ALLOCATED
, "allocated",
9589 (*code
)->loc
, 1, e
);
9590 block
->block
->next
= temp_code
;
9593 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9596 /* Replace the first actual arg with the component of the
9598 gfc_free_expr (this_code
->ext
.actual
->expr
);
9599 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9600 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9602 /* If the LHS variable is allocatable and wasn't allocated and
9603 the temporary is allocatable, pointer assign the address of
9604 the freshly allocated LHS to the temporary. */
9605 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9606 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9611 cond
= gfc_get_expr ();
9612 cond
->ts
.type
= BT_LOGICAL
;
9613 cond
->ts
.kind
= gfc_default_logical_kind
;
9614 cond
->expr_type
= EXPR_OP
;
9615 cond
->where
= (*code
)->loc
;
9616 cond
->value
.op
.op
= INTRINSIC_NOT
;
9617 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9618 GFC_ISYM_ALLOCATED
, "allocated",
9619 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9620 block
= gfc_get_code (EXEC_IF
);
9621 block
->block
= gfc_get_code (EXEC_IF
);
9622 block
->block
->expr1
= cond
;
9623 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9625 NULL
, NULL
, (*code
)->loc
);
9626 add_code_to_chain (&block
, &head
, &tail
);
9630 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9632 /* Don't add intrinsic assignments since they are already
9633 effected by the intrinsic assignment of the structure. */
9634 gfc_free_statements (this_code
);
9639 add_code_to_chain (&this_code
, &head
, &tail
);
9643 /* Transfer the value to the final result. */
9644 this_code
= build_assignment (EXEC_ASSIGN
,
9646 comp1
, comp2
, (*code
)->loc
);
9647 add_code_to_chain (&this_code
, &head
, &tail
);
9651 /* Put the temporary assignments at the top of the generated code. */
9652 if (tmp_head
&& component_assignment_level
== 1)
9654 gfc_append_code (tmp_head
, head
);
9656 tmp_head
= tmp_tail
= NULL
;
9659 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9660 // not accidentally deallocated. Hence, nullify t1.
9661 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9662 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9668 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9669 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9670 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9671 block
= gfc_get_code (EXEC_IF
);
9672 block
->block
= gfc_get_code (EXEC_IF
);
9673 block
->block
->expr1
= cond
;
9674 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9675 t1
, gfc_get_null_expr (&(*code
)->loc
),
9676 NULL
, NULL
, (*code
)->loc
);
9677 gfc_append_code (tail
, block
);
9681 /* Now attach the remaining code chain to the input code. Step on
9682 to the end of the new code since resolution is complete. */
9683 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9684 tail
->next
= (*code
)->next
;
9685 /* Overwrite 'code' because this would place the intrinsic assignment
9686 before the temporary for the lhs is created. */
9687 gfc_free_expr ((*code
)->expr1
);
9688 gfc_free_expr ((*code
)->expr2
);
9694 component_assignment_level
--;
9698 /* Given a block of code, recursively resolve everything pointed to by this
9702 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9704 int omp_workshare_save
;
9705 int forall_save
, do_concurrent_save
;
9709 frame
.prev
= cs_base
;
9713 find_reachable_labels (code
);
9715 for (; code
; code
= code
->next
)
9717 frame
.current
= code
;
9718 forall_save
= forall_flag
;
9719 do_concurrent_save
= gfc_do_concurrent_flag
;
9721 if (code
->op
== EXEC_FORALL
)
9724 gfc_resolve_forall (code
, ns
, forall_save
);
9727 else if (code
->block
)
9729 omp_workshare_save
= -1;
9732 case EXEC_OMP_PARALLEL_WORKSHARE
:
9733 omp_workshare_save
= omp_workshare_flag
;
9734 omp_workshare_flag
= 1;
9735 gfc_resolve_omp_parallel_blocks (code
, ns
);
9737 case EXEC_OMP_PARALLEL
:
9738 case EXEC_OMP_PARALLEL_DO
:
9739 case EXEC_OMP_PARALLEL_SECTIONS
:
9741 omp_workshare_save
= omp_workshare_flag
;
9742 omp_workshare_flag
= 0;
9743 gfc_resolve_omp_parallel_blocks (code
, ns
);
9746 gfc_resolve_omp_do_blocks (code
, ns
);
9748 case EXEC_SELECT_TYPE
:
9749 /* Blocks are handled in resolve_select_type because we have
9750 to transform the SELECT TYPE into ASSOCIATE first. */
9752 case EXEC_DO_CONCURRENT
:
9753 gfc_do_concurrent_flag
= 1;
9754 gfc_resolve_blocks (code
->block
, ns
);
9755 gfc_do_concurrent_flag
= 2;
9757 case EXEC_OMP_WORKSHARE
:
9758 omp_workshare_save
= omp_workshare_flag
;
9759 omp_workshare_flag
= 1;
9762 gfc_resolve_blocks (code
->block
, ns
);
9766 if (omp_workshare_save
!= -1)
9767 omp_workshare_flag
= omp_workshare_save
;
9771 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9772 t
= gfc_resolve_expr (code
->expr1
);
9773 forall_flag
= forall_save
;
9774 gfc_do_concurrent_flag
= do_concurrent_save
;
9776 if (!gfc_resolve_expr (code
->expr2
))
9779 if (code
->op
== EXEC_ALLOCATE
9780 && !gfc_resolve_expr (code
->expr3
))
9786 case EXEC_END_BLOCK
:
9787 case EXEC_END_NESTED_BLOCK
:
9791 case EXEC_ERROR_STOP
:
9795 case EXEC_ASSIGN_CALL
:
9800 case EXEC_SYNC_IMAGES
:
9801 case EXEC_SYNC_MEMORY
:
9802 resolve_sync (code
);
9807 resolve_lock_unlock (code
);
9811 /* Keep track of which entry we are up to. */
9812 current_entry_id
= code
->ext
.entry
->id
;
9816 resolve_where (code
, NULL
);
9820 if (code
->expr1
!= NULL
)
9822 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9823 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9824 "INTEGER variable", &code
->expr1
->where
);
9825 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9826 gfc_error ("Variable '%s' has not been assigned a target "
9827 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9828 &code
->expr1
->where
);
9831 resolve_branch (code
->label1
, code
);
9835 if (code
->expr1
!= NULL
9836 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9837 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9838 "INTEGER return specifier", &code
->expr1
->where
);
9841 case EXEC_INIT_ASSIGN
:
9842 case EXEC_END_PROCEDURE
:
9849 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
9853 if (resolve_ordinary_assign (code
, ns
))
9855 if (code
->op
== EXEC_COMPCALL
)
9861 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
9862 if (code
->expr1
->ts
.type
== BT_DERIVED
9863 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
9864 generate_component_assignments (&code
, ns
);
9868 case EXEC_LABEL_ASSIGN
:
9869 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9870 gfc_error ("Label %d referenced at %L is never defined",
9871 code
->label1
->value
, &code
->label1
->where
);
9873 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9874 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9875 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9876 != gfc_default_integer_kind
9877 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9878 gfc_error ("ASSIGN statement at %L requires a scalar "
9879 "default INTEGER variable", &code
->expr1
->where
);
9882 case EXEC_POINTER_ASSIGN
:
9889 /* This is both a variable definition and pointer assignment
9890 context, so check both of them. For rank remapping, a final
9891 array ref may be present on the LHS and fool gfc_expr_attr
9892 used in gfc_check_vardef_context. Remove it. */
9893 e
= remove_last_array_ref (code
->expr1
);
9894 t
= gfc_check_vardef_context (e
, true, false, false,
9895 _("pointer assignment"));
9897 t
= gfc_check_vardef_context (e
, false, false, false,
9898 _("pointer assignment"));
9903 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9907 case EXEC_ARITHMETIC_IF
:
9909 && code
->expr1
->ts
.type
!= BT_INTEGER
9910 && code
->expr1
->ts
.type
!= BT_REAL
)
9911 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9912 "expression", &code
->expr1
->where
);
9914 resolve_branch (code
->label1
, code
);
9915 resolve_branch (code
->label2
, code
);
9916 resolve_branch (code
->label3
, code
);
9920 if (t
&& code
->expr1
!= NULL
9921 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9922 || code
->expr1
->rank
!= 0))
9923 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9924 &code
->expr1
->where
);
9929 resolve_call (code
);
9934 resolve_typebound_subroutine (code
);
9938 resolve_ppc_call (code
);
9942 /* Select is complicated. Also, a SELECT construct could be
9943 a transformed computed GOTO. */
9944 resolve_select (code
, false);
9947 case EXEC_SELECT_TYPE
:
9948 resolve_select_type (code
, ns
);
9952 resolve_block_construct (code
);
9956 if (code
->ext
.iterator
!= NULL
)
9958 gfc_iterator
*iter
= code
->ext
.iterator
;
9959 if (gfc_resolve_iterator (iter
, true, false))
9960 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9965 if (code
->expr1
== NULL
)
9966 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9968 && (code
->expr1
->rank
!= 0
9969 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9970 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9971 "a scalar LOGICAL expression", &code
->expr1
->where
);
9976 resolve_allocate_deallocate (code
, "ALLOCATE");
9980 case EXEC_DEALLOCATE
:
9982 resolve_allocate_deallocate (code
, "DEALLOCATE");
9987 if (!gfc_resolve_open (code
->ext
.open
))
9990 resolve_branch (code
->ext
.open
->err
, code
);
9994 if (!gfc_resolve_close (code
->ext
.close
))
9997 resolve_branch (code
->ext
.close
->err
, code
);
10000 case EXEC_BACKSPACE
:
10004 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10007 resolve_branch (code
->ext
.filepos
->err
, code
);
10011 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10014 resolve_branch (code
->ext
.inquire
->err
, code
);
10017 case EXEC_IOLENGTH
:
10018 gcc_assert (code
->ext
.inquire
!= NULL
);
10019 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10022 resolve_branch (code
->ext
.inquire
->err
, code
);
10026 if (!gfc_resolve_wait (code
->ext
.wait
))
10029 resolve_branch (code
->ext
.wait
->err
, code
);
10030 resolve_branch (code
->ext
.wait
->end
, code
);
10031 resolve_branch (code
->ext
.wait
->eor
, code
);
10036 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10039 resolve_branch (code
->ext
.dt
->err
, code
);
10040 resolve_branch (code
->ext
.dt
->end
, code
);
10041 resolve_branch (code
->ext
.dt
->eor
, code
);
10044 case EXEC_TRANSFER
:
10045 resolve_transfer (code
);
10048 case EXEC_DO_CONCURRENT
:
10050 resolve_forall_iterators (code
->ext
.forall_iterator
);
10052 if (code
->expr1
!= NULL
10053 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10054 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10055 "expression", &code
->expr1
->where
);
10058 case EXEC_OMP_ATOMIC
:
10059 case EXEC_OMP_BARRIER
:
10060 case EXEC_OMP_CRITICAL
:
10061 case EXEC_OMP_FLUSH
:
10063 case EXEC_OMP_MASTER
:
10064 case EXEC_OMP_ORDERED
:
10065 case EXEC_OMP_SECTIONS
:
10066 case EXEC_OMP_SINGLE
:
10067 case EXEC_OMP_TASKWAIT
:
10068 case EXEC_OMP_TASKYIELD
:
10069 case EXEC_OMP_WORKSHARE
:
10070 gfc_resolve_omp_directive (code
, ns
);
10073 case EXEC_OMP_PARALLEL
:
10074 case EXEC_OMP_PARALLEL_DO
:
10075 case EXEC_OMP_PARALLEL_SECTIONS
:
10076 case EXEC_OMP_PARALLEL_WORKSHARE
:
10077 case EXEC_OMP_TASK
:
10078 omp_workshare_save
= omp_workshare_flag
;
10079 omp_workshare_flag
= 0;
10080 gfc_resolve_omp_directive (code
, ns
);
10081 omp_workshare_flag
= omp_workshare_save
;
10085 gfc_internal_error ("resolve_code(): Bad statement code");
10089 cs_base
= frame
.prev
;
10093 /* Resolve initial values and make sure they are compatible with
10097 resolve_values (gfc_symbol
*sym
)
10101 if (sym
->value
== NULL
)
10104 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10105 t
= resolve_structure_cons (sym
->value
, 1);
10107 t
= gfc_resolve_expr (sym
->value
);
10112 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10116 /* Verify any BIND(C) derived types in the namespace so we can report errors
10117 for them once, rather than for each variable declared of that type. */
10120 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10122 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10123 && derived_sym
->attr
.is_bind_c
== 1)
10124 verify_bind_c_derived_type (derived_sym
);
10130 /* Verify that any binding labels used in a given namespace do not collide
10131 with the names or binding labels of any global symbols. Multiple INTERFACE
10132 for the same procedure are permitted. */
10135 gfc_verify_binding_labels (gfc_symbol
*sym
)
10138 const char *module
;
10140 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10141 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10144 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10147 module
= sym
->module
;
10148 else if (sym
->ns
&& sym
->ns
->proc_name
10149 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10150 module
= sym
->ns
->proc_name
->name
;
10151 else if (sym
->ns
&& sym
->ns
->parent
10152 && sym
->ns
&& sym
->ns
->parent
->proc_name
10153 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10154 module
= sym
->ns
->parent
->proc_name
->name
;
10160 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10163 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10164 gsym
->where
= sym
->declared_at
;
10165 gsym
->sym_name
= sym
->name
;
10166 gsym
->binding_label
= sym
->binding_label
;
10167 gsym
->ns
= sym
->ns
;
10168 gsym
->mod_name
= module
;
10169 if (sym
->attr
.function
)
10170 gsym
->type
= GSYM_FUNCTION
;
10171 else if (sym
->attr
.subroutine
)
10172 gsym
->type
= GSYM_SUBROUTINE
;
10173 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10174 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10178 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10180 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10181 "identifier as entity at %L", sym
->name
,
10182 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10183 /* Clear the binding label to prevent checking multiple times. */
10184 sym
->binding_label
= NULL
;
10187 else if (sym
->attr
.flavor
== FL_VARIABLE
10188 && (strcmp (module
, gsym
->mod_name
) != 0
10189 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10191 /* This can only happen if the variable is defined in a module - if it
10192 isn't the same module, reject it. */
10193 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10194 "the same global identifier as entity at %L from module %s",
10195 sym
->name
, module
, sym
->binding_label
,
10196 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10197 sym
->binding_label
= NULL
;
10199 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10200 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10201 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10202 && sym
!= gsym
->ns
->proc_name
10203 && (module
!= gsym
->mod_name
10204 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10205 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10207 /* Print an error if the procedure is defined multiple times; we have to
10208 exclude references to the same procedure via module association or
10209 multiple checks for the same procedure. */
10210 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10211 "global identifier as entity at %L", sym
->name
,
10212 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10213 sym
->binding_label
= NULL
;
10218 /* Resolve an index expression. */
10221 resolve_index_expr (gfc_expr
*e
)
10223 if (!gfc_resolve_expr (e
))
10226 if (!gfc_simplify_expr (e
, 0))
10229 if (!gfc_specification_expr (e
))
10236 /* Resolve a charlen structure. */
10239 resolve_charlen (gfc_charlen
*cl
)
10242 bool saved_specification_expr
;
10248 saved_specification_expr
= specification_expr
;
10249 specification_expr
= true;
10251 if (cl
->length_from_typespec
)
10253 if (!gfc_resolve_expr (cl
->length
))
10255 specification_expr
= saved_specification_expr
;
10259 if (!gfc_simplify_expr (cl
->length
, 0))
10261 specification_expr
= saved_specification_expr
;
10268 if (!resolve_index_expr (cl
->length
))
10270 specification_expr
= saved_specification_expr
;
10275 /* "If the character length parameter value evaluates to a negative
10276 value, the length of character entities declared is zero." */
10277 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10279 if (gfc_option
.warn_surprising
)
10280 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10281 " the length has been set to zero",
10282 &cl
->length
->where
, i
);
10283 gfc_replace_expr (cl
->length
,
10284 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10287 /* Check that the character length is not too large. */
10288 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10289 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10290 && cl
->length
->ts
.type
== BT_INTEGER
10291 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10293 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10294 specification_expr
= saved_specification_expr
;
10298 specification_expr
= saved_specification_expr
;
10303 /* Test for non-constant shape arrays. */
10306 is_non_constant_shape_array (gfc_symbol
*sym
)
10312 not_constant
= false;
10313 if (sym
->as
!= NULL
)
10315 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10316 has not been simplified; parameter array references. Do the
10317 simplification now. */
10318 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10320 e
= sym
->as
->lower
[i
];
10321 if (e
&& (!resolve_index_expr(e
)
10322 || !gfc_is_constant_expr (e
)))
10323 not_constant
= true;
10324 e
= sym
->as
->upper
[i
];
10325 if (e
&& (!resolve_index_expr(e
)
10326 || !gfc_is_constant_expr (e
)))
10327 not_constant
= true;
10330 return not_constant
;
10333 /* Given a symbol and an initialization expression, add code to initialize
10334 the symbol to the function entry. */
10336 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10340 gfc_namespace
*ns
= sym
->ns
;
10342 /* Search for the function namespace if this is a contained
10343 function without an explicit result. */
10344 if (sym
->attr
.function
&& sym
== sym
->result
10345 && sym
->name
!= sym
->ns
->proc_name
->name
)
10347 ns
= ns
->contained
;
10348 for (;ns
; ns
= ns
->sibling
)
10349 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10355 gfc_free_expr (init
);
10359 /* Build an l-value expression for the result. */
10360 lval
= gfc_lval_expr_from_sym (sym
);
10362 /* Add the code at scope entry. */
10363 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10364 init_st
->next
= ns
->code
;
10365 ns
->code
= init_st
;
10367 /* Assign the default initializer to the l-value. */
10368 init_st
->loc
= sym
->declared_at
;
10369 init_st
->expr1
= lval
;
10370 init_st
->expr2
= init
;
10373 /* Assign the default initializer to a derived type variable or result. */
10376 apply_default_init (gfc_symbol
*sym
)
10378 gfc_expr
*init
= NULL
;
10380 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10383 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10384 init
= gfc_default_initializer (&sym
->ts
);
10386 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10389 build_init_assign (sym
, init
);
10390 sym
->attr
.referenced
= 1;
10393 /* Build an initializer for a local integer, real, complex, logical, or
10394 character variable, based on the command line flags finit-local-zero,
10395 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10396 null if the symbol should not have a default initialization. */
10398 build_default_init_expr (gfc_symbol
*sym
)
10401 gfc_expr
*init_expr
;
10404 /* These symbols should never have a default initialization. */
10405 if (sym
->attr
.allocatable
10406 || sym
->attr
.external
10408 || sym
->attr
.pointer
10409 || sym
->attr
.in_equivalence
10410 || sym
->attr
.in_common
10413 || sym
->attr
.cray_pointee
10414 || sym
->attr
.cray_pointer
10418 /* Now we'll try to build an initializer expression. */
10419 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10420 &sym
->declared_at
);
10422 /* We will only initialize integers, reals, complex, logicals, and
10423 characters, and only if the corresponding command-line flags
10424 were set. Otherwise, we free init_expr and return null. */
10425 switch (sym
->ts
.type
)
10428 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10429 mpz_set_si (init_expr
->value
.integer
,
10430 gfc_option
.flag_init_integer_value
);
10433 gfc_free_expr (init_expr
);
10439 switch (gfc_option
.flag_init_real
)
10441 case GFC_INIT_REAL_SNAN
:
10442 init_expr
->is_snan
= 1;
10443 /* Fall through. */
10444 case GFC_INIT_REAL_NAN
:
10445 mpfr_set_nan (init_expr
->value
.real
);
10448 case GFC_INIT_REAL_INF
:
10449 mpfr_set_inf (init_expr
->value
.real
, 1);
10452 case GFC_INIT_REAL_NEG_INF
:
10453 mpfr_set_inf (init_expr
->value
.real
, -1);
10456 case GFC_INIT_REAL_ZERO
:
10457 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10461 gfc_free_expr (init_expr
);
10468 switch (gfc_option
.flag_init_real
)
10470 case GFC_INIT_REAL_SNAN
:
10471 init_expr
->is_snan
= 1;
10472 /* Fall through. */
10473 case GFC_INIT_REAL_NAN
:
10474 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10475 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10478 case GFC_INIT_REAL_INF
:
10479 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10480 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10483 case GFC_INIT_REAL_NEG_INF
:
10484 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10485 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10488 case GFC_INIT_REAL_ZERO
:
10489 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10493 gfc_free_expr (init_expr
);
10500 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10501 init_expr
->value
.logical
= 0;
10502 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10503 init_expr
->value
.logical
= 1;
10506 gfc_free_expr (init_expr
);
10512 /* For characters, the length must be constant in order to
10513 create a default initializer. */
10514 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10515 && sym
->ts
.u
.cl
->length
10516 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10518 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10519 init_expr
->value
.character
.length
= char_len
;
10520 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10521 for (i
= 0; i
< char_len
; i
++)
10522 init_expr
->value
.character
.string
[i
]
10523 = (unsigned char) gfc_option
.flag_init_character_value
;
10527 gfc_free_expr (init_expr
);
10530 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10531 && sym
->ts
.u
.cl
->length
)
10533 gfc_actual_arglist
*arg
;
10534 init_expr
= gfc_get_expr ();
10535 init_expr
->where
= sym
->declared_at
;
10536 init_expr
->ts
= sym
->ts
;
10537 init_expr
->expr_type
= EXPR_FUNCTION
;
10538 init_expr
->value
.function
.isym
=
10539 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10540 init_expr
->value
.function
.name
= "repeat";
10541 arg
= gfc_get_actual_arglist ();
10542 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10544 arg
->expr
->value
.character
.string
[0]
10545 = gfc_option
.flag_init_character_value
;
10546 arg
->next
= gfc_get_actual_arglist ();
10547 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10548 init_expr
->value
.function
.actual
= arg
;
10553 gfc_free_expr (init_expr
);
10559 /* Add an initialization expression to a local variable. */
10561 apply_default_init_local (gfc_symbol
*sym
)
10563 gfc_expr
*init
= NULL
;
10565 /* The symbol should be a variable or a function return value. */
10566 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10567 || (sym
->attr
.function
&& sym
->result
!= sym
))
10570 /* Try to build the initializer expression. If we can't initialize
10571 this symbol, then init will be NULL. */
10572 init
= build_default_init_expr (sym
);
10576 /* For saved variables, we don't want to add an initializer at function
10577 entry, so we just add a static initializer. Note that automatic variables
10578 are stack allocated even with -fno-automatic; we have also to exclude
10579 result variable, which are also nonstatic. */
10580 if (sym
->attr
.save
|| sym
->ns
->save_all
10581 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10582 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10584 /* Don't clobber an existing initializer! */
10585 gcc_assert (sym
->value
== NULL
);
10590 build_init_assign (sym
, init
);
10594 /* Resolution of common features of flavors variable and procedure. */
10597 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10599 gfc_array_spec
*as
;
10601 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10602 as
= CLASS_DATA (sym
)->as
;
10606 /* Constraints on deferred shape variable. */
10607 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10609 bool pointer
, allocatable
, dimension
;
10611 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10613 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10614 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10615 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10619 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10620 allocatable
= sym
->attr
.allocatable
;
10621 dimension
= sym
->attr
.dimension
;
10626 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10628 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10629 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10632 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10633 "'%s' at %L may not be ALLOCATABLE",
10634 sym
->name
, &sym
->declared_at
))
10638 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10640 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10641 "assumed rank", sym
->name
, &sym
->declared_at
);
10647 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10648 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10650 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10651 sym
->name
, &sym
->declared_at
);
10656 /* Constraints on polymorphic variables. */
10657 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10660 if (sym
->attr
.class_ok
10661 && !sym
->attr
.select_type_temporary
10662 && !UNLIMITED_POLY (sym
)
10663 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10665 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10666 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10667 &sym
->declared_at
);
10672 /* Assume that use associated symbols were checked in the module ns.
10673 Class-variables that are associate-names are also something special
10674 and excepted from the test. */
10675 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10677 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10678 "or pointer", sym
->name
, &sym
->declared_at
);
10687 /* Additional checks for symbols with flavor variable and derived
10688 type. To be called from resolve_fl_variable. */
10691 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10693 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10695 /* Check to see if a derived type is blocked from being host
10696 associated by the presence of another class I symbol in the same
10697 namespace. 14.6.1.3 of the standard and the discussion on
10698 comp.lang.fortran. */
10699 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10700 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10703 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10704 if (s
&& s
->attr
.generic
)
10705 s
= gfc_find_dt_in_generic (s
);
10706 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10708 gfc_error ("The type '%s' cannot be host associated at %L "
10709 "because it is blocked by an incompatible object "
10710 "of the same name declared at %L",
10711 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10717 /* 4th constraint in section 11.3: "If an object of a type for which
10718 component-initialization is specified (R429) appears in the
10719 specification-part of a module and does not have the ALLOCATABLE
10720 or POINTER attribute, the object shall have the SAVE attribute."
10722 The check for initializers is performed with
10723 gfc_has_default_initializer because gfc_default_initializer generates
10724 a hidden default for allocatable components. */
10725 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10726 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10727 && !sym
->ns
->save_all
&& !sym
->attr
.save
10728 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10729 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10730 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10731 "'%s' at %L, needed due to the default "
10732 "initialization", sym
->name
, &sym
->declared_at
))
10735 /* Assign default initializer. */
10736 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10737 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10739 sym
->value
= gfc_default_initializer (&sym
->ts
);
10746 /* Resolve symbols with flavor variable. */
10749 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10751 int no_init_flag
, automatic_flag
;
10753 const char *auto_save_msg
;
10754 bool saved_specification_expr
;
10756 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10759 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
10762 /* Set this flag to check that variables are parameters of all entries.
10763 This check is effected by the call to gfc_resolve_expr through
10764 is_non_constant_shape_array. */
10765 saved_specification_expr
= specification_expr
;
10766 specification_expr
= true;
10768 if (sym
->ns
->proc_name
10769 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10770 || sym
->ns
->proc_name
->attr
.is_main_program
)
10771 && !sym
->attr
.use_assoc
10772 && !sym
->attr
.allocatable
10773 && !sym
->attr
.pointer
10774 && is_non_constant_shape_array (sym
))
10776 /* The shape of a main program or module array needs to be
10778 gfc_error ("The module or main program array '%s' at %L must "
10779 "have constant shape", sym
->name
, &sym
->declared_at
);
10780 specification_expr
= saved_specification_expr
;
10784 /* Constraints on deferred type parameter. */
10785 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10787 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10788 "requires either the pointer or allocatable attribute",
10789 sym
->name
, &sym
->declared_at
);
10790 specification_expr
= saved_specification_expr
;
10794 if (sym
->ts
.type
== BT_CHARACTER
)
10796 /* Make sure that character string variables with assumed length are
10797 dummy arguments. */
10798 e
= sym
->ts
.u
.cl
->length
;
10799 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10800 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
10802 gfc_error ("Entity with assumed character length at %L must be a "
10803 "dummy argument or a PARAMETER", &sym
->declared_at
);
10804 specification_expr
= saved_specification_expr
;
10808 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10810 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10811 specification_expr
= saved_specification_expr
;
10815 if (!gfc_is_constant_expr (e
)
10816 && !(e
->expr_type
== EXPR_VARIABLE
10817 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10819 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10820 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10821 || sym
->ns
->proc_name
->attr
.is_main_program
))
10823 gfc_error ("'%s' at %L must have constant character length "
10824 "in this context", sym
->name
, &sym
->declared_at
);
10825 specification_expr
= saved_specification_expr
;
10828 if (sym
->attr
.in_common
)
10830 gfc_error ("COMMON variable '%s' at %L must have constant "
10831 "character length", sym
->name
, &sym
->declared_at
);
10832 specification_expr
= saved_specification_expr
;
10838 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10839 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10841 /* Determine if the symbol may not have an initializer. */
10842 no_init_flag
= automatic_flag
= 0;
10843 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10844 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10846 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10847 && is_non_constant_shape_array (sym
))
10849 no_init_flag
= automatic_flag
= 1;
10851 /* Also, they must not have the SAVE attribute.
10852 SAVE_IMPLICIT is checked below. */
10853 if (sym
->as
&& sym
->attr
.codimension
)
10855 int corank
= sym
->as
->corank
;
10856 sym
->as
->corank
= 0;
10857 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10858 sym
->as
->corank
= corank
;
10860 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10862 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10863 specification_expr
= saved_specification_expr
;
10868 /* Ensure that any initializer is simplified. */
10870 gfc_simplify_expr (sym
->value
, 1);
10872 /* Reject illegal initializers. */
10873 if (!sym
->mark
&& sym
->value
)
10875 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10876 && CLASS_DATA (sym
)->attr
.allocatable
))
10877 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10878 sym
->name
, &sym
->declared_at
);
10879 else if (sym
->attr
.external
)
10880 gfc_error ("External '%s' at %L cannot have an initializer",
10881 sym
->name
, &sym
->declared_at
);
10882 else if (sym
->attr
.dummy
10883 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10884 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10885 sym
->name
, &sym
->declared_at
);
10886 else if (sym
->attr
.intrinsic
)
10887 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10888 sym
->name
, &sym
->declared_at
);
10889 else if (sym
->attr
.result
)
10890 gfc_error ("Function result '%s' at %L cannot have an initializer",
10891 sym
->name
, &sym
->declared_at
);
10892 else if (automatic_flag
)
10893 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10894 sym
->name
, &sym
->declared_at
);
10896 goto no_init_error
;
10897 specification_expr
= saved_specification_expr
;
10902 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10904 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10905 specification_expr
= saved_specification_expr
;
10909 specification_expr
= saved_specification_expr
;
10914 /* Resolve a procedure. */
10917 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10919 gfc_formal_arglist
*arg
;
10921 if (sym
->attr
.function
10922 && !resolve_fl_var_and_proc (sym
, mp_flag
))
10925 if (sym
->ts
.type
== BT_CHARACTER
)
10927 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10929 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10930 && !resolve_charlen (cl
))
10933 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10934 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10936 gfc_error ("Character-valued statement function '%s' at %L must "
10937 "have constant length", sym
->name
, &sym
->declared_at
);
10942 /* Ensure that derived type for are not of a private type. Internal
10943 module procedures are excluded by 2.2.3.3 - i.e., they are not
10944 externally accessible and can access all the objects accessible in
10946 if (!(sym
->ns
->parent
10947 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10948 && gfc_check_symbol_access (sym
))
10950 gfc_interface
*iface
;
10952 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
10955 && arg
->sym
->ts
.type
== BT_DERIVED
10956 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10957 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10958 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
10959 "and cannot be a dummy argument"
10960 " of '%s', which is PUBLIC at %L",
10961 arg
->sym
->name
, sym
->name
,
10962 &sym
->declared_at
))
10964 /* Stop this message from recurring. */
10965 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10970 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10971 PRIVATE to the containing module. */
10972 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10974 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10977 && arg
->sym
->ts
.type
== BT_DERIVED
10978 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10979 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10980 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10981 "PUBLIC interface '%s' at %L "
10982 "takes dummy arguments of '%s' which "
10983 "is PRIVATE", iface
->sym
->name
,
10984 sym
->name
, &iface
->sym
->declared_at
,
10985 gfc_typename(&arg
->sym
->ts
)))
10987 /* Stop this message from recurring. */
10988 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10994 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10995 PRIVATE to the containing module. */
10996 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10998 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11001 && arg
->sym
->ts
.type
== BT_DERIVED
11002 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11003 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11004 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
11005 "PUBLIC interface '%s' at %L takes "
11006 "dummy arguments of '%s' which is "
11007 "PRIVATE", iface
->sym
->name
,
11008 sym
->name
, &iface
->sym
->declared_at
,
11009 gfc_typename(&arg
->sym
->ts
)))
11011 /* Stop this message from recurring. */
11012 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11019 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11020 && !sym
->attr
.proc_pointer
)
11022 gfc_error ("Function '%s' at %L cannot have an initializer",
11023 sym
->name
, &sym
->declared_at
);
11027 /* An external symbol may not have an initializer because it is taken to be
11028 a procedure. Exception: Procedure Pointers. */
11029 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11031 gfc_error ("External object '%s' at %L may not have an initializer",
11032 sym
->name
, &sym
->declared_at
);
11036 /* An elemental function is required to return a scalar 12.7.1 */
11037 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11039 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11040 "result", sym
->name
, &sym
->declared_at
);
11041 /* Reset so that the error only occurs once. */
11042 sym
->attr
.elemental
= 0;
11046 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11047 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11049 gfc_error ("Statement function '%s' at %L may not have pointer or "
11050 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11054 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11055 char-len-param shall not be array-valued, pointer-valued, recursive
11056 or pure. ....snip... A character value of * may only be used in the
11057 following ways: (i) Dummy arg of procedure - dummy associates with
11058 actual length; (ii) To declare a named constant; or (iii) External
11059 function - but length must be declared in calling scoping unit. */
11060 if (sym
->attr
.function
11061 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11062 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11064 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11065 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11067 if (sym
->as
&& sym
->as
->rank
)
11068 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11069 "array-valued", sym
->name
, &sym
->declared_at
);
11071 if (sym
->attr
.pointer
)
11072 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11073 "pointer-valued", sym
->name
, &sym
->declared_at
);
11075 if (sym
->attr
.pure
)
11076 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11077 "pure", sym
->name
, &sym
->declared_at
);
11079 if (sym
->attr
.recursive
)
11080 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11081 "recursive", sym
->name
, &sym
->declared_at
);
11086 /* Appendix B.2 of the standard. Contained functions give an
11087 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11088 character length is an F2003 feature. */
11089 if (!sym
->attr
.contained
11090 && gfc_current_form
!= FORM_FIXED
11091 && !sym
->ts
.deferred
)
11092 gfc_notify_std (GFC_STD_F95_OBS
,
11093 "CHARACTER(*) function '%s' at %L",
11094 sym
->name
, &sym
->declared_at
);
11097 /* F2008, C1218. */
11098 if (sym
->attr
.elemental
)
11100 if (sym
->attr
.proc_pointer
)
11102 gfc_error ("Procedure pointer '%s' at %L shall not be elemental",
11103 sym
->name
, &sym
->declared_at
);
11106 if (sym
->attr
.dummy
)
11108 gfc_error ("Dummy procedure '%s' at %L shall not be elemental",
11109 sym
->name
, &sym
->declared_at
);
11114 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11116 gfc_formal_arglist
*curr_arg
;
11117 int has_non_interop_arg
= 0;
11119 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11120 sym
->common_block
))
11122 /* Clear these to prevent looking at them again if there was an
11124 sym
->attr
.is_bind_c
= 0;
11125 sym
->attr
.is_c_interop
= 0;
11126 sym
->ts
.is_c_interop
= 0;
11130 /* So far, no errors have been found. */
11131 sym
->attr
.is_c_interop
= 1;
11132 sym
->ts
.is_c_interop
= 1;
11135 curr_arg
= gfc_sym_get_dummy_args (sym
);
11136 while (curr_arg
!= NULL
)
11138 /* Skip implicitly typed dummy args here. */
11139 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11140 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11141 /* If something is found to fail, record the fact so we
11142 can mark the symbol for the procedure as not being
11143 BIND(C) to try and prevent multiple errors being
11145 has_non_interop_arg
= 1;
11147 curr_arg
= curr_arg
->next
;
11150 /* See if any of the arguments were not interoperable and if so, clear
11151 the procedure symbol to prevent duplicate error messages. */
11152 if (has_non_interop_arg
!= 0)
11154 sym
->attr
.is_c_interop
= 0;
11155 sym
->ts
.is_c_interop
= 0;
11156 sym
->attr
.is_bind_c
= 0;
11160 if (!sym
->attr
.proc_pointer
)
11162 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11164 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11165 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11168 if (sym
->attr
.intent
)
11170 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11171 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11174 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11176 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11177 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11180 if (sym
->attr
.external
&& sym
->attr
.function
11181 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11182 || sym
->attr
.contained
))
11184 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11185 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11188 if (strcmp ("ppr@", sym
->name
) == 0)
11190 gfc_error ("Procedure pointer result '%s' at %L "
11191 "is missing the pointer attribute",
11192 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11201 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11202 been defined and we now know their defined arguments, check that they fulfill
11203 the requirements of the standard for procedures used as finalizers. */
11206 gfc_resolve_finalizers (gfc_symbol
* derived
)
11208 gfc_finalizer
* list
;
11209 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11210 bool result
= true;
11211 bool seen_scalar
= false;
11213 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11216 /* Walk over the list of finalizer-procedures, check them, and if any one
11217 does not fit in with the standard's definition, print an error and remove
11218 it from the list. */
11219 prev_link
= &derived
->f2k_derived
->finalizers
;
11220 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11222 gfc_formal_arglist
*dummy_args
;
11227 /* Skip this finalizer if we already resolved it. */
11228 if (list
->proc_tree
)
11230 prev_link
= &(list
->next
);
11234 /* Check this exists and is a SUBROUTINE. */
11235 if (!list
->proc_sym
->attr
.subroutine
)
11237 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11238 list
->proc_sym
->name
, &list
->where
);
11242 /* We should have exactly one argument. */
11243 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11244 if (!dummy_args
|| dummy_args
->next
)
11246 gfc_error ("FINAL procedure at %L must have exactly one argument",
11250 arg
= dummy_args
->sym
;
11252 /* This argument must be of our type. */
11253 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11255 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11256 &arg
->declared_at
, derived
->name
);
11260 /* It must neither be a pointer nor allocatable nor optional. */
11261 if (arg
->attr
.pointer
)
11263 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11264 &arg
->declared_at
);
11267 if (arg
->attr
.allocatable
)
11269 gfc_error ("Argument of FINAL procedure at %L must not be"
11270 " ALLOCATABLE", &arg
->declared_at
);
11273 if (arg
->attr
.optional
)
11275 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11276 &arg
->declared_at
);
11280 /* It must not be INTENT(OUT). */
11281 if (arg
->attr
.intent
== INTENT_OUT
)
11283 gfc_error ("Argument of FINAL procedure at %L must not be"
11284 " INTENT(OUT)", &arg
->declared_at
);
11288 /* Warn if the procedure is non-scalar and not assumed shape. */
11289 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11290 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11291 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11292 " shape argument", &arg
->declared_at
);
11294 /* Check that it does not match in kind and rank with a FINAL procedure
11295 defined earlier. To really loop over the *earlier* declarations,
11296 we need to walk the tail of the list as new ones were pushed at the
11298 /* TODO: Handle kind parameters once they are implemented. */
11299 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11300 for (i
= list
->next
; i
; i
= i
->next
)
11302 gfc_formal_arglist
*dummy_args
;
11304 /* Argument list might be empty; that is an error signalled earlier,
11305 but we nevertheless continued resolving. */
11306 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11309 gfc_symbol
* i_arg
= dummy_args
->sym
;
11310 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11311 if (i_rank
== my_rank
)
11313 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11314 " rank (%d) as '%s'",
11315 list
->proc_sym
->name
, &list
->where
, my_rank
,
11316 i
->proc_sym
->name
);
11322 /* Is this the/a scalar finalizer procedure? */
11323 if (!arg
->as
|| arg
->as
->rank
== 0)
11324 seen_scalar
= true;
11326 /* Find the symtree for this procedure. */
11327 gcc_assert (!list
->proc_tree
);
11328 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11330 prev_link
= &list
->next
;
11333 /* Remove wrong nodes immediately from the list so we don't risk any
11334 troubles in the future when they might fail later expectations. */
11338 *prev_link
= list
->next
;
11339 gfc_free_finalizer (i
);
11342 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11343 were nodes in the list, must have been for arrays. It is surely a good
11344 idea to have a scalar version there if there's something to finalize. */
11345 if (gfc_option
.warn_surprising
&& result
&& !seen_scalar
)
11346 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11347 " defined at %L, suggest also scalar one",
11348 derived
->name
, &derived
->declared_at
);
11350 gfc_find_derived_vtab (derived
);
11355 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11358 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11359 const char* generic_name
, locus where
)
11361 gfc_symbol
*sym1
, *sym2
;
11362 const char *pass1
, *pass2
;
11364 gcc_assert (t1
->specific
&& t2
->specific
);
11365 gcc_assert (!t1
->specific
->is_generic
);
11366 gcc_assert (!t2
->specific
->is_generic
);
11367 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11369 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11370 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11375 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11376 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11377 || sym1
->attr
.function
!= sym2
->attr
.function
)
11379 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11380 " GENERIC '%s' at %L",
11381 sym1
->name
, sym2
->name
, generic_name
, &where
);
11385 /* Compare the interfaces. */
11386 if (t1
->specific
->nopass
)
11388 else if (t1
->specific
->pass_arg
)
11389 pass1
= t1
->specific
->pass_arg
;
11391 pass1
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11392 if (t2
->specific
->nopass
)
11394 else if (t2
->specific
->pass_arg
)
11395 pass2
= t2
->specific
->pass_arg
;
11397 pass2
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11398 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11399 NULL
, 0, pass1
, pass2
))
11401 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11402 sym1
->name
, sym2
->name
, generic_name
, &where
);
11410 /* Worker function for resolving a generic procedure binding; this is used to
11411 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11413 The difference between those cases is finding possible inherited bindings
11414 that are overridden, as one has to look for them in tb_sym_root,
11415 tb_uop_root or tb_op, respectively. Thus the caller must already find
11416 the super-type and set p->overridden correctly. */
11419 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11420 gfc_typebound_proc
* p
, const char* name
)
11422 gfc_tbp_generic
* target
;
11423 gfc_symtree
* first_target
;
11424 gfc_symtree
* inherited
;
11426 gcc_assert (p
&& p
->is_generic
);
11428 /* Try to find the specific bindings for the symtrees in our target-list. */
11429 gcc_assert (p
->u
.generic
);
11430 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11431 if (!target
->specific
)
11433 gfc_typebound_proc
* overridden_tbp
;
11434 gfc_tbp_generic
* g
;
11435 const char* target_name
;
11437 target_name
= target
->specific_st
->name
;
11439 /* Defined for this type directly. */
11440 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11442 target
->specific
= target
->specific_st
->n
.tb
;
11443 goto specific_found
;
11446 /* Look for an inherited specific binding. */
11449 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11454 gcc_assert (inherited
->n
.tb
);
11455 target
->specific
= inherited
->n
.tb
;
11456 goto specific_found
;
11460 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11461 " at %L", target_name
, name
, &p
->where
);
11464 /* Once we've found the specific binding, check it is not ambiguous with
11465 other specifics already found or inherited for the same GENERIC. */
11467 gcc_assert (target
->specific
);
11469 /* This must really be a specific binding! */
11470 if (target
->specific
->is_generic
)
11472 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11473 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11477 /* Check those already resolved on this type directly. */
11478 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11479 if (g
!= target
&& g
->specific
11480 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11483 /* Check for ambiguity with inherited specific targets. */
11484 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11485 overridden_tbp
= overridden_tbp
->overridden
)
11486 if (overridden_tbp
->is_generic
)
11488 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11490 gcc_assert (g
->specific
);
11491 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11497 /* If we attempt to "overwrite" a specific binding, this is an error. */
11498 if (p
->overridden
&& !p
->overridden
->is_generic
)
11500 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11501 " the same name", name
, &p
->where
);
11505 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11506 all must have the same attributes here. */
11507 first_target
= p
->u
.generic
->specific
->u
.specific
;
11508 gcc_assert (first_target
);
11509 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11510 p
->function
= first_target
->n
.sym
->attr
.function
;
11516 /* Resolve a GENERIC procedure binding for a derived type. */
11519 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11521 gfc_symbol
* super_type
;
11523 /* Find the overridden binding if any. */
11524 st
->n
.tb
->overridden
= NULL
;
11525 super_type
= gfc_get_derived_super_type (derived
);
11528 gfc_symtree
* overridden
;
11529 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11532 if (overridden
&& overridden
->n
.tb
)
11533 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11536 /* Resolve using worker function. */
11537 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11541 /* Retrieve the target-procedure of an operator binding and do some checks in
11542 common for intrinsic and user-defined type-bound operators. */
11545 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11547 gfc_symbol
* target_proc
;
11549 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11550 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11551 gcc_assert (target_proc
);
11553 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11554 if (target
->specific
->nopass
)
11556 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11560 return target_proc
;
11564 /* Resolve a type-bound intrinsic operator. */
11567 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11568 gfc_typebound_proc
* p
)
11570 gfc_symbol
* super_type
;
11571 gfc_tbp_generic
* target
;
11573 /* If there's already an error here, do nothing (but don't fail again). */
11577 /* Operators should always be GENERIC bindings. */
11578 gcc_assert (p
->is_generic
);
11580 /* Look for an overridden binding. */
11581 super_type
= gfc_get_derived_super_type (derived
);
11582 if (super_type
&& super_type
->f2k_derived
)
11583 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11586 p
->overridden
= NULL
;
11588 /* Resolve general GENERIC properties using worker function. */
11589 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11592 /* Check the targets to be procedures of correct interface. */
11593 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11595 gfc_symbol
* target_proc
;
11597 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11601 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11604 /* Add target to non-typebound operator list. */
11605 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11606 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11608 gfc_interface
*head
, *intr
;
11609 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11611 head
= derived
->ns
->op
[op
];
11612 intr
= gfc_get_interface ();
11613 intr
->sym
= target_proc
;
11614 intr
->where
= p
->where
;
11616 derived
->ns
->op
[op
] = intr
;
11628 /* Resolve a type-bound user operator (tree-walker callback). */
11630 static gfc_symbol
* resolve_bindings_derived
;
11631 static bool resolve_bindings_result
;
11633 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11636 resolve_typebound_user_op (gfc_symtree
* stree
)
11638 gfc_symbol
* super_type
;
11639 gfc_tbp_generic
* target
;
11641 gcc_assert (stree
&& stree
->n
.tb
);
11643 if (stree
->n
.tb
->error
)
11646 /* Operators should always be GENERIC bindings. */
11647 gcc_assert (stree
->n
.tb
->is_generic
);
11649 /* Find overridden procedure, if any. */
11650 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11651 if (super_type
&& super_type
->f2k_derived
)
11653 gfc_symtree
* overridden
;
11654 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11655 stree
->name
, true, NULL
);
11657 if (overridden
&& overridden
->n
.tb
)
11658 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11661 stree
->n
.tb
->overridden
= NULL
;
11663 /* Resolve basically using worker function. */
11664 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11667 /* Check the targets to be functions of correct interface. */
11668 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11670 gfc_symbol
* target_proc
;
11672 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11676 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11683 resolve_bindings_result
= false;
11684 stree
->n
.tb
->error
= 1;
11688 /* Resolve the type-bound procedures for a derived type. */
11691 resolve_typebound_procedure (gfc_symtree
* stree
)
11695 gfc_symbol
* me_arg
;
11696 gfc_symbol
* super_type
;
11697 gfc_component
* comp
;
11699 gcc_assert (stree
);
11701 /* Undefined specific symbol from GENERIC target definition. */
11705 if (stree
->n
.tb
->error
)
11708 /* If this is a GENERIC binding, use that routine. */
11709 if (stree
->n
.tb
->is_generic
)
11711 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11716 /* Get the target-procedure to check it. */
11717 gcc_assert (!stree
->n
.tb
->is_generic
);
11718 gcc_assert (stree
->n
.tb
->u
.specific
);
11719 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11720 where
= stree
->n
.tb
->where
;
11722 /* Default access should already be resolved from the parser. */
11723 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11725 if (stree
->n
.tb
->deferred
)
11727 if (!check_proc_interface (proc
, &where
))
11732 /* Check for F08:C465. */
11733 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11734 || (proc
->attr
.proc
!= PROC_MODULE
11735 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11736 || proc
->attr
.abstract
)
11738 gfc_error ("'%s' must be a module procedure or an external procedure with"
11739 " an explicit interface at %L", proc
->name
, &where
);
11744 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11745 stree
->n
.tb
->function
= proc
->attr
.function
;
11747 /* Find the super-type of the current derived type. We could do this once and
11748 store in a global if speed is needed, but as long as not I believe this is
11749 more readable and clearer. */
11750 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11752 /* If PASS, resolve and check arguments if not already resolved / loaded
11753 from a .mod file. */
11754 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11756 gfc_formal_arglist
*dummy_args
;
11758 dummy_args
= gfc_sym_get_dummy_args (proc
);
11759 if (stree
->n
.tb
->pass_arg
)
11761 gfc_formal_arglist
*i
;
11763 /* If an explicit passing argument name is given, walk the arg-list
11764 and look for it. */
11767 stree
->n
.tb
->pass_arg_num
= 1;
11768 for (i
= dummy_args
; i
; i
= i
->next
)
11770 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11775 ++stree
->n
.tb
->pass_arg_num
;
11780 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11782 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11783 stree
->n
.tb
->pass_arg
);
11789 /* Otherwise, take the first one; there should in fact be at least
11791 stree
->n
.tb
->pass_arg_num
= 1;
11794 gfc_error ("Procedure '%s' with PASS at %L must have at"
11795 " least one argument", proc
->name
, &where
);
11798 me_arg
= dummy_args
->sym
;
11801 /* Now check that the argument-type matches and the passed-object
11802 dummy argument is generally fine. */
11804 gcc_assert (me_arg
);
11806 if (me_arg
->ts
.type
!= BT_CLASS
)
11808 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11809 " at %L", proc
->name
, &where
);
11813 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11814 != resolve_bindings_derived
)
11816 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11817 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11818 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11822 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11823 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11825 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11826 " scalar", proc
->name
, &where
);
11829 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11831 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11832 " be ALLOCATABLE", proc
->name
, &where
);
11835 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11837 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11838 " be POINTER", proc
->name
, &where
);
11843 /* If we are extending some type, check that we don't override a procedure
11844 flagged NON_OVERRIDABLE. */
11845 stree
->n
.tb
->overridden
= NULL
;
11848 gfc_symtree
* overridden
;
11849 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11850 stree
->name
, true, NULL
);
11854 if (overridden
->n
.tb
)
11855 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11857 if (!gfc_check_typebound_override (stree
, overridden
))
11862 /* See if there's a name collision with a component directly in this type. */
11863 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11864 if (!strcmp (comp
->name
, stree
->name
))
11866 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11868 stree
->name
, &where
, resolve_bindings_derived
->name
);
11872 /* Try to find a name collision with an inherited component. */
11873 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11875 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11876 " component of '%s'",
11877 stree
->name
, &where
, resolve_bindings_derived
->name
);
11881 stree
->n
.tb
->error
= 0;
11885 resolve_bindings_result
= false;
11886 stree
->n
.tb
->error
= 1;
11891 resolve_typebound_procedures (gfc_symbol
* derived
)
11894 gfc_symbol
* super_type
;
11896 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11899 super_type
= gfc_get_derived_super_type (derived
);
11901 resolve_symbol (super_type
);
11903 resolve_bindings_derived
= derived
;
11904 resolve_bindings_result
= true;
11906 if (derived
->f2k_derived
->tb_sym_root
)
11907 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11908 &resolve_typebound_procedure
);
11910 if (derived
->f2k_derived
->tb_uop_root
)
11911 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11912 &resolve_typebound_user_op
);
11914 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11916 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11917 if (p
&& !resolve_typebound_intrinsic_op (derived
,
11918 (gfc_intrinsic_op
)op
, p
))
11919 resolve_bindings_result
= false;
11922 return resolve_bindings_result
;
11926 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11927 to give all identical derived types the same backend_decl. */
11929 add_dt_to_dt_list (gfc_symbol
*derived
)
11931 gfc_dt_list
*dt_list
;
11933 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11934 if (derived
== dt_list
->derived
)
11937 dt_list
= gfc_get_dt_list ();
11938 dt_list
->next
= gfc_derived_types
;
11939 dt_list
->derived
= derived
;
11940 gfc_derived_types
= dt_list
;
11944 /* Ensure that a derived-type is really not abstract, meaning that every
11945 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11948 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11953 if (!ensure_not_abstract_walker (sub
, st
->left
))
11955 if (!ensure_not_abstract_walker (sub
, st
->right
))
11958 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11960 gfc_symtree
* overriding
;
11961 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11964 gcc_assert (overriding
->n
.tb
);
11965 if (overriding
->n
.tb
->deferred
)
11967 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11968 " '%s' is DEFERRED and not overridden",
11969 sub
->name
, &sub
->declared_at
, st
->name
);
11978 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11980 /* The algorithm used here is to recursively travel up the ancestry of sub
11981 and for each ancestor-type, check all bindings. If any of them is
11982 DEFERRED, look it up starting from sub and see if the found (overriding)
11983 binding is not DEFERRED.
11984 This is not the most efficient way to do this, but it should be ok and is
11985 clearer than something sophisticated. */
11987 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11989 if (!ancestor
->attr
.abstract
)
11992 /* Walk bindings of this ancestor. */
11993 if (ancestor
->f2k_derived
)
11996 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12001 /* Find next ancestor type and recurse on it. */
12002 ancestor
= gfc_get_derived_super_type (ancestor
);
12004 return ensure_not_abstract (sub
, ancestor
);
12010 /* This check for typebound defined assignments is done recursively
12011 since the order in which derived types are resolved is not always in
12012 order of the declarations. */
12015 check_defined_assignments (gfc_symbol
*derived
)
12019 for (c
= derived
->components
; c
; c
= c
->next
)
12021 if (c
->ts
.type
!= BT_DERIVED
12023 || c
->attr
.allocatable
12024 || c
->attr
.proc_pointer_comp
12025 || c
->attr
.class_pointer
12026 || c
->attr
.proc_pointer
)
12029 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12030 || (c
->ts
.u
.derived
->f2k_derived
12031 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12033 derived
->attr
.defined_assign_comp
= 1;
12037 check_defined_assignments (c
->ts
.u
.derived
);
12038 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12040 derived
->attr
.defined_assign_comp
= 1;
12047 /* Resolve the components of a derived type. This does not have to wait until
12048 resolution stage, but can be done as soon as the dt declaration has been
12052 resolve_fl_derived0 (gfc_symbol
*sym
)
12054 gfc_symbol
* super_type
;
12057 if (sym
->attr
.unlimited_polymorphic
)
12060 super_type
= gfc_get_derived_super_type (sym
);
12063 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12065 gfc_error ("As extending type '%s' at %L has a coarray component, "
12066 "parent type '%s' shall also have one", sym
->name
,
12067 &sym
->declared_at
, super_type
->name
);
12071 /* Ensure the extended type gets resolved before we do. */
12072 if (super_type
&& !resolve_fl_derived0 (super_type
))
12075 /* An ABSTRACT type must be extensible. */
12076 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12078 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12079 sym
->name
, &sym
->declared_at
);
12083 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12086 for ( ; c
!= NULL
; c
= c
->next
)
12088 if (c
->attr
.artificial
)
12091 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12092 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
12094 gfc_error ("Deferred-length character component '%s' at %L is not "
12095 "yet supported", c
->name
, &c
->loc
);
12100 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12101 && c
->attr
.codimension
12102 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12104 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12105 "deferred shape", c
->name
, &c
->loc
);
12110 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12111 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12113 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12114 "shall not be a coarray", c
->name
, &c
->loc
);
12119 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12120 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12121 || c
->attr
.allocatable
))
12123 gfc_error ("Component '%s' at %L with coarray component "
12124 "shall be a nonpointer, nonallocatable scalar",
12130 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12132 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12133 "is not an array pointer", c
->name
, &c
->loc
);
12137 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12139 gfc_symbol
*ifc
= c
->ts
.interface
;
12141 if (!sym
->attr
.vtype
12142 && !check_proc_interface (ifc
, &c
->loc
))
12145 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12147 /* Resolve interface and copy attributes. */
12148 if (ifc
->formal
&& !ifc
->formal_ns
)
12149 resolve_symbol (ifc
);
12150 if (ifc
->attr
.intrinsic
)
12151 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12155 c
->ts
= ifc
->result
->ts
;
12156 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12157 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12158 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12159 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12160 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12165 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12166 c
->attr
.pointer
= ifc
->attr
.pointer
;
12167 c
->attr
.dimension
= ifc
->attr
.dimension
;
12168 c
->as
= gfc_copy_array_spec (ifc
->as
);
12169 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12171 c
->ts
.interface
= ifc
;
12172 c
->attr
.function
= ifc
->attr
.function
;
12173 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12175 c
->attr
.pure
= ifc
->attr
.pure
;
12176 c
->attr
.elemental
= ifc
->attr
.elemental
;
12177 c
->attr
.recursive
= ifc
->attr
.recursive
;
12178 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12179 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12180 /* Copy char length. */
12181 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12183 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12184 if (cl
->length
&& !cl
->resolved
12185 && !gfc_resolve_expr (cl
->length
))
12191 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12193 /* Since PPCs are not implicitly typed, a PPC without an explicit
12194 interface must be a subroutine. */
12195 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12198 /* Procedure pointer components: Check PASS arg. */
12199 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12200 && !sym
->attr
.vtype
)
12202 gfc_symbol
* me_arg
;
12204 if (c
->tb
->pass_arg
)
12206 gfc_formal_arglist
* i
;
12208 /* If an explicit passing argument name is given, walk the arg-list
12209 and look for it. */
12212 c
->tb
->pass_arg_num
= 1;
12213 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12215 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12220 c
->tb
->pass_arg_num
++;
12225 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12226 "at %L has no argument '%s'", c
->name
,
12227 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12234 /* Otherwise, take the first one; there should in fact be at least
12236 c
->tb
->pass_arg_num
= 1;
12237 if (!c
->ts
.interface
->formal
)
12239 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12240 "must have at least one argument",
12245 me_arg
= c
->ts
.interface
->formal
->sym
;
12248 /* Now check that the argument-type matches. */
12249 gcc_assert (me_arg
);
12250 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12251 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12252 || (me_arg
->ts
.type
== BT_CLASS
12253 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12255 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12256 " the derived type '%s'", me_arg
->name
, c
->name
,
12257 me_arg
->name
, &c
->loc
, sym
->name
);
12262 /* Check for C453. */
12263 if (me_arg
->attr
.dimension
)
12265 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12266 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12272 if (me_arg
->attr
.pointer
)
12274 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12275 "may not have the POINTER attribute", me_arg
->name
,
12276 c
->name
, me_arg
->name
, &c
->loc
);
12281 if (me_arg
->attr
.allocatable
)
12283 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12284 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12285 me_arg
->name
, &c
->loc
);
12290 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12291 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12292 " at %L", c
->name
, &c
->loc
);
12296 /* Check type-spec if this is not the parent-type component. */
12297 if (((sym
->attr
.is_class
12298 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12299 || c
!= sym
->components
->ts
.u
.derived
->components
))
12300 || (!sym
->attr
.is_class
12301 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12302 && !sym
->attr
.vtype
12303 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12306 /* If this type is an extension, set the accessibility of the parent
12309 && ((sym
->attr
.is_class
12310 && c
== sym
->components
->ts
.u
.derived
->components
)
12311 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12312 && strcmp (super_type
->name
, c
->name
) == 0)
12313 c
->attr
.access
= super_type
->attr
.access
;
12315 /* If this type is an extension, see if this component has the same name
12316 as an inherited type-bound procedure. */
12317 if (super_type
&& !sym
->attr
.is_class
12318 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12320 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12321 " inherited type-bound procedure",
12322 c
->name
, sym
->name
, &c
->loc
);
12326 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12327 && !c
->ts
.deferred
)
12329 if (c
->ts
.u
.cl
->length
== NULL
12330 || (!resolve_charlen(c
->ts
.u
.cl
))
12331 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12333 gfc_error ("Character length of component '%s' needs to "
12334 "be a constant specification expression at %L",
12336 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12341 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12342 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12344 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12345 "length must be a POINTER or ALLOCATABLE",
12346 c
->name
, sym
->name
, &c
->loc
);
12350 if (c
->ts
.type
== BT_DERIVED
12351 && sym
->component_access
!= ACCESS_PRIVATE
12352 && gfc_check_symbol_access (sym
)
12353 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12354 && !c
->ts
.u
.derived
->attr
.use_assoc
12355 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12356 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12357 "PRIVATE type and cannot be a component of "
12358 "'%s', which is PUBLIC at %L", c
->name
,
12359 sym
->name
, &sym
->declared_at
))
12362 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12364 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12365 "type %s", c
->name
, &c
->loc
, sym
->name
);
12369 if (sym
->attr
.sequence
)
12371 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12373 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12374 "not have the SEQUENCE attribute",
12375 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12380 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12381 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12382 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12383 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12384 CLASS_DATA (c
)->ts
.u
.derived
12385 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12387 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12388 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12389 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12391 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12392 "that has not been declared", c
->name
, sym
->name
,
12397 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12398 && CLASS_DATA (c
)->attr
.class_pointer
12399 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12400 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12401 && !UNLIMITED_POLY (c
))
12403 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12404 "that has not been declared", c
->name
, sym
->name
,
12410 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12411 && (!c
->attr
.class_ok
12412 || !(CLASS_DATA (c
)->attr
.class_pointer
12413 || CLASS_DATA (c
)->attr
.allocatable
)))
12415 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12416 "or pointer", c
->name
, &c
->loc
);
12417 /* Prevent a recurrence of the error. */
12418 c
->ts
.type
= BT_UNKNOWN
;
12422 /* Ensure that all the derived type components are put on the
12423 derived type list; even in formal namespaces, where derived type
12424 pointer components might not have been declared. */
12425 if (c
->ts
.type
== BT_DERIVED
12427 && c
->ts
.u
.derived
->components
12429 && sym
!= c
->ts
.u
.derived
)
12430 add_dt_to_dt_list (c
->ts
.u
.derived
);
12432 if (!gfc_resolve_array_spec (c
->as
,
12433 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12434 || c
->attr
.allocatable
)))
12437 if (c
->initializer
&& !sym
->attr
.vtype
12438 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12442 check_defined_assignments (sym
);
12444 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12445 sym
->attr
.defined_assign_comp
12446 = super_type
->attr
.defined_assign_comp
;
12448 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12449 all DEFERRED bindings are overridden. */
12450 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12451 && !sym
->attr
.is_class
12452 && !ensure_not_abstract (sym
, super_type
))
12455 /* Add derived type to the derived type list. */
12456 add_dt_to_dt_list (sym
);
12458 /* Check if the type is finalizable. This is done in order to ensure that the
12459 finalization wrapper is generated early enough. */
12460 gfc_is_finalizable (sym
, NULL
);
12466 /* The following procedure does the full resolution of a derived type,
12467 including resolution of all type-bound procedures (if present). In contrast
12468 to 'resolve_fl_derived0' this can only be done after the module has been
12469 parsed completely. */
12472 resolve_fl_derived (gfc_symbol
*sym
)
12474 gfc_symbol
*gen_dt
= NULL
;
12476 if (sym
->attr
.unlimited_polymorphic
)
12479 if (!sym
->attr
.is_class
)
12480 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12481 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12482 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12483 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12484 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12485 "'%s' at %L being the same name as derived "
12486 "type at %L", sym
->name
,
12487 gen_dt
->generic
->sym
== sym
12488 ? gen_dt
->generic
->next
->sym
->name
12489 : gen_dt
->generic
->sym
->name
,
12490 gen_dt
->generic
->sym
== sym
12491 ? &gen_dt
->generic
->next
->sym
->declared_at
12492 : &gen_dt
->generic
->sym
->declared_at
,
12493 &sym
->declared_at
))
12496 /* Resolve the finalizer procedures. */
12497 if (!gfc_resolve_finalizers (sym
))
12500 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12502 /* Fix up incomplete CLASS symbols. */
12503 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12504 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12506 /* Nothing more to do for unlimited polymorphic entities. */
12507 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12509 else if (vptr
->ts
.u
.derived
== NULL
)
12511 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12513 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12517 if (!resolve_fl_derived0 (sym
))
12520 /* Resolve the type-bound procedures. */
12521 if (!resolve_typebound_procedures (sym
))
12529 resolve_fl_namelist (gfc_symbol
*sym
)
12534 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12536 /* Check again, the check in match only works if NAMELIST comes
12538 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12540 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12541 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12545 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12546 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12547 "with assumed shape in namelist '%s' at %L",
12548 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12551 if (is_non_constant_shape_array (nl
->sym
)
12552 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12553 "with nonconstant shape in namelist '%s' at %L",
12554 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12557 if (nl
->sym
->ts
.type
== BT_CHARACTER
12558 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12559 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12560 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12561 "nonconstant character length in "
12562 "namelist '%s' at %L", nl
->sym
->name
,
12563 sym
->name
, &sym
->declared_at
))
12566 /* FIXME: Once UDDTIO is implemented, the following can be
12568 if (nl
->sym
->ts
.type
== BT_CLASS
)
12570 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12571 "polymorphic and requires a defined input/output "
12572 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12576 if (nl
->sym
->ts
.type
== BT_DERIVED
12577 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12578 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12580 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12581 "namelist '%s' at %L with ALLOCATABLE "
12582 "or POINTER components", nl
->sym
->name
,
12583 sym
->name
, &sym
->declared_at
))
12586 /* FIXME: Once UDDTIO is implemented, the following can be
12588 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12589 "ALLOCATABLE or POINTER components and thus requires "
12590 "a defined input/output procedure", nl
->sym
->name
,
12591 sym
->name
, &sym
->declared_at
);
12596 /* Reject PRIVATE objects in a PUBLIC namelist. */
12597 if (gfc_check_symbol_access (sym
))
12599 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12601 if (!nl
->sym
->attr
.use_assoc
12602 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12603 && !gfc_check_symbol_access (nl
->sym
))
12605 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12606 "cannot be member of PUBLIC namelist '%s' at %L",
12607 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12611 /* Types with private components that came here by USE-association. */
12612 if (nl
->sym
->ts
.type
== BT_DERIVED
12613 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12615 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12616 "components and cannot be member of namelist '%s' at %L",
12617 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12621 /* Types with private components that are defined in the same module. */
12622 if (nl
->sym
->ts
.type
== BT_DERIVED
12623 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12624 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12626 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12627 "cannot be a member of PUBLIC namelist '%s' at %L",
12628 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12635 /* 14.1.2 A module or internal procedure represent local entities
12636 of the same type as a namelist member and so are not allowed. */
12637 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12639 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12642 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12643 if ((nl
->sym
== sym
->ns
->proc_name
)
12645 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12650 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12651 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12653 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12654 "attribute in '%s' at %L", nlsym
->name
,
12655 &sym
->declared_at
);
12665 resolve_fl_parameter (gfc_symbol
*sym
)
12667 /* A parameter array's shape needs to be constant. */
12668 if (sym
->as
!= NULL
12669 && (sym
->as
->type
== AS_DEFERRED
12670 || is_non_constant_shape_array (sym
)))
12672 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12673 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12677 /* Make sure a parameter that has been implicitly typed still
12678 matches the implicit type, since PARAMETER statements can precede
12679 IMPLICIT statements. */
12680 if (sym
->attr
.implicit_type
12681 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12684 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12685 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12689 /* Make sure the types of derived parameters are consistent. This
12690 type checking is deferred until resolution because the type may
12691 refer to a derived type from the host. */
12692 if (sym
->ts
.type
== BT_DERIVED
12693 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12695 gfc_error ("Incompatible derived type in PARAMETER at %L",
12696 &sym
->value
->where
);
12703 /* Do anything necessary to resolve a symbol. Right now, we just
12704 assume that an otherwise unknown symbol is a variable. This sort
12705 of thing commonly happens for symbols in module. */
12708 resolve_symbol (gfc_symbol
*sym
)
12710 int check_constant
, mp_flag
;
12711 gfc_symtree
*symtree
;
12712 gfc_symtree
*this_symtree
;
12715 symbol_attribute class_attr
;
12716 gfc_array_spec
*as
;
12717 bool saved_specification_expr
;
12723 if (sym
->attr
.artificial
)
12726 if (sym
->attr
.unlimited_polymorphic
)
12729 if (sym
->attr
.flavor
== FL_UNKNOWN
12730 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12731 && !sym
->attr
.generic
&& !sym
->attr
.external
12732 && sym
->attr
.if_source
== IFSRC_UNKNOWN
12733 && sym
->ts
.type
== BT_UNKNOWN
))
12736 /* If we find that a flavorless symbol is an interface in one of the
12737 parent namespaces, find its symtree in this namespace, free the
12738 symbol and set the symtree to point to the interface symbol. */
12739 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12741 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12742 if (symtree
&& (symtree
->n
.sym
->generic
||
12743 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12744 && sym
->ns
->construct_entities
)))
12746 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12748 gfc_release_symbol (sym
);
12749 symtree
->n
.sym
->refs
++;
12750 this_symtree
->n
.sym
= symtree
->n
.sym
;
12755 /* Otherwise give it a flavor according to such attributes as
12757 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12758 && sym
->attr
.intrinsic
== 0)
12759 sym
->attr
.flavor
= FL_VARIABLE
;
12760 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12762 sym
->attr
.flavor
= FL_PROCEDURE
;
12763 if (sym
->attr
.dimension
)
12764 sym
->attr
.function
= 1;
12768 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12769 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12771 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12772 && !resolve_procedure_interface (sym
))
12775 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12776 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12778 if (sym
->attr
.external
)
12779 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12780 "at %L", &sym
->declared_at
);
12782 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12783 "at %L", &sym
->declared_at
);
12788 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
12791 /* Symbols that are module procedures with results (functions) have
12792 the types and array specification copied for type checking in
12793 procedures that call them, as well as for saving to a module
12794 file. These symbols can't stand the scrutiny that their results
12796 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12798 /* Make sure that the intrinsic is consistent with its internal
12799 representation. This needs to be done before assigning a default
12800 type to avoid spurious warnings. */
12801 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12802 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
12805 /* Resolve associate names. */
12807 resolve_assoc_var (sym
, true);
12809 /* Assign default type to symbols that need one and don't have one. */
12810 if (sym
->ts
.type
== BT_UNKNOWN
)
12812 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12814 gfc_set_default_type (sym
, 1, NULL
);
12817 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12818 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12819 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12820 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12822 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12824 /* The specific case of an external procedure should emit an error
12825 in the case that there is no implicit type. */
12827 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12830 /* Result may be in another namespace. */
12831 resolve_symbol (sym
->result
);
12833 if (!sym
->result
->attr
.proc_pointer
)
12835 sym
->ts
= sym
->result
->ts
;
12836 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12837 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12838 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12839 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12840 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12845 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12847 bool saved_specification_expr
= specification_expr
;
12848 specification_expr
= true;
12849 gfc_resolve_array_spec (sym
->result
->as
, false);
12850 specification_expr
= saved_specification_expr
;
12853 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12855 as
= CLASS_DATA (sym
)->as
;
12856 class_attr
= CLASS_DATA (sym
)->attr
;
12857 class_attr
.pointer
= class_attr
.class_pointer
;
12861 class_attr
= sym
->attr
;
12866 if (sym
->attr
.contiguous
12867 && (!class_attr
.dimension
12868 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12869 && !class_attr
.pointer
)))
12871 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12872 "array pointer or an assumed-shape or assumed-rank array",
12873 sym
->name
, &sym
->declared_at
);
12877 /* Assumed size arrays and assumed shape arrays must be dummy
12878 arguments. Array-spec's of implied-shape should have been resolved to
12879 AS_EXPLICIT already. */
12883 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12884 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12885 || as
->type
== AS_ASSUMED_SHAPE
)
12886 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
12888 if (as
->type
== AS_ASSUMED_SIZE
)
12889 gfc_error ("Assumed size array at %L must be a dummy argument",
12890 &sym
->declared_at
);
12892 gfc_error ("Assumed shape array at %L must be a dummy argument",
12893 &sym
->declared_at
);
12896 /* TS 29113, C535a. */
12897 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
12898 && !sym
->attr
.select_type_temporary
)
12900 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12901 &sym
->declared_at
);
12904 if (as
->type
== AS_ASSUMED_RANK
12905 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12907 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12908 "CODIMENSION attribute", &sym
->declared_at
);
12913 /* Make sure symbols with known intent or optional are really dummy
12914 variable. Because of ENTRY statement, this has to be deferred
12915 until resolution time. */
12917 if (!sym
->attr
.dummy
12918 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12920 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12924 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12926 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12927 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12931 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12933 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12934 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12936 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12937 "attribute must have constant length",
12938 sym
->name
, &sym
->declared_at
);
12942 if (sym
->ts
.is_c_interop
12943 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12945 gfc_error ("C interoperable character dummy variable '%s' at %L "
12946 "with VALUE attribute must have length one",
12947 sym
->name
, &sym
->declared_at
);
12952 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12953 && sym
->ts
.u
.derived
->attr
.generic
)
12955 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12956 if (!sym
->ts
.u
.derived
)
12958 gfc_error ("The derived type '%s' at %L is of type '%s', "
12959 "which has not been defined", sym
->name
,
12960 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12961 sym
->ts
.type
= BT_UNKNOWN
;
12966 /* Use the same constraints as TYPE(*), except for the type check
12967 and that only scalars and assumed-size arrays are permitted. */
12968 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
12970 if (!sym
->attr
.dummy
)
12972 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12973 "a dummy argument", sym
->name
, &sym
->declared_at
);
12977 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
12978 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
12979 && sym
->ts
.type
!= BT_COMPLEX
)
12981 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12982 "of type TYPE(*) or of an numeric intrinsic type",
12983 sym
->name
, &sym
->declared_at
);
12987 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12988 || sym
->attr
.pointer
|| sym
->attr
.value
)
12990 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12991 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
12992 "attribute", sym
->name
, &sym
->declared_at
);
12996 if (sym
->attr
.intent
== INTENT_OUT
)
12998 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12999 "have the INTENT(OUT) attribute",
13000 sym
->name
, &sym
->declared_at
);
13003 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13005 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13006 "either be a scalar or an assumed-size array",
13007 sym
->name
, &sym
->declared_at
);
13011 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13012 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13014 sym
->ts
.type
= BT_ASSUMED
;
13015 sym
->as
= gfc_get_array_spec ();
13016 sym
->as
->type
= AS_ASSUMED_SIZE
;
13018 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13020 else if (sym
->ts
.type
== BT_ASSUMED
)
13022 /* TS 29113, C407a. */
13023 if (!sym
->attr
.dummy
)
13025 gfc_error ("Assumed type of variable %s at %L is only permitted "
13026 "for dummy variables", sym
->name
, &sym
->declared_at
);
13029 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13030 || sym
->attr
.pointer
|| sym
->attr
.value
)
13032 gfc_error ("Assumed-type variable %s at %L may not have the "
13033 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13034 sym
->name
, &sym
->declared_at
);
13037 if (sym
->attr
.intent
== INTENT_OUT
)
13039 gfc_error ("Assumed-type variable %s at %L may not have the "
13040 "INTENT(OUT) attribute",
13041 sym
->name
, &sym
->declared_at
);
13044 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13046 gfc_error ("Assumed-type variable %s at %L shall not be an "
13047 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13052 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13053 do this for something that was implicitly typed because that is handled
13054 in gfc_set_default_type. Handle dummy arguments and procedure
13055 definitions separately. Also, anything that is use associated is not
13056 handled here but instead is handled in the module it is declared in.
13057 Finally, derived type definitions are allowed to be BIND(C) since that
13058 only implies that they're interoperable, and they are checked fully for
13059 interoperability when a variable is declared of that type. */
13060 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13061 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13062 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13066 /* First, make sure the variable is declared at the
13067 module-level scope (J3/04-007, Section 15.3). */
13068 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13069 sym
->attr
.in_common
== 0)
13071 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13072 "is neither a COMMON block nor declared at the "
13073 "module level scope", sym
->name
, &(sym
->declared_at
));
13076 else if (sym
->common_head
!= NULL
)
13078 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13082 /* If type() declaration, we need to verify that the components
13083 of the given type are all C interoperable, etc. */
13084 if (sym
->ts
.type
== BT_DERIVED
&&
13085 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13087 /* Make sure the user marked the derived type as BIND(C). If
13088 not, call the verify routine. This could print an error
13089 for the derived type more than once if multiple variables
13090 of that type are declared. */
13091 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13092 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13096 /* Verify the variable itself as C interoperable if it
13097 is BIND(C). It is not possible for this to succeed if
13098 the verify_bind_c_derived_type failed, so don't have to handle
13099 any error returned by verify_bind_c_derived_type. */
13100 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13101 sym
->common_block
);
13106 /* clear the is_bind_c flag to prevent reporting errors more than
13107 once if something failed. */
13108 sym
->attr
.is_bind_c
= 0;
13113 /* If a derived type symbol has reached this point, without its
13114 type being declared, we have an error. Notice that most
13115 conditions that produce undefined derived types have already
13116 been dealt with. However, the likes of:
13117 implicit type(t) (t) ..... call foo (t) will get us here if
13118 the type is not declared in the scope of the implicit
13119 statement. Change the type to BT_UNKNOWN, both because it is so
13120 and to prevent an ICE. */
13121 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13122 && sym
->ts
.u
.derived
->components
== NULL
13123 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13125 gfc_error ("The derived type '%s' at %L is of type '%s', "
13126 "which has not been defined", sym
->name
,
13127 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13128 sym
->ts
.type
= BT_UNKNOWN
;
13132 /* Make sure that the derived type has been resolved and that the
13133 derived type is visible in the symbol's namespace, if it is a
13134 module function and is not PRIVATE. */
13135 if (sym
->ts
.type
== BT_DERIVED
13136 && sym
->ts
.u
.derived
->attr
.use_assoc
13137 && sym
->ns
->proc_name
13138 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13139 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13142 /* Unless the derived-type declaration is use associated, Fortran 95
13143 does not allow public entries of private derived types.
13144 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13145 161 in 95-006r3. */
13146 if (sym
->ts
.type
== BT_DERIVED
13147 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13148 && !sym
->ts
.u
.derived
->attr
.use_assoc
13149 && gfc_check_symbol_access (sym
)
13150 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13151 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13152 "derived type '%s'",
13153 (sym
->attr
.flavor
== FL_PARAMETER
)
13154 ? "parameter" : "variable",
13155 sym
->name
, &sym
->declared_at
,
13156 sym
->ts
.u
.derived
->name
))
13159 /* F2008, C1302. */
13160 if (sym
->ts
.type
== BT_DERIVED
13161 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13162 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13163 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13164 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13166 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13167 "type LOCK_TYPE must be a coarray", sym
->name
,
13168 &sym
->declared_at
);
13172 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13173 default initialization is defined (5.1.2.4.4). */
13174 if (sym
->ts
.type
== BT_DERIVED
13176 && sym
->attr
.intent
== INTENT_OUT
13178 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13180 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13182 if (c
->initializer
)
13184 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13185 "ASSUMED SIZE and so cannot have a default initializer",
13186 sym
->name
, &sym
->declared_at
);
13193 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13194 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13196 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13197 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13202 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13203 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13204 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13205 || class_attr
.codimension
)
13206 && (sym
->attr
.result
|| sym
->result
== sym
))
13208 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13209 "a coarray component", sym
->name
, &sym
->declared_at
);
13214 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13215 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13217 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13218 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13223 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13224 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13225 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13226 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13227 || class_attr
.allocatable
))
13229 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13230 "nonpointer, nonallocatable scalar, which is not a coarray",
13231 sym
->name
, &sym
->declared_at
);
13235 /* F2008, C526. The function-result case was handled above. */
13236 if (class_attr
.codimension
13237 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13238 || sym
->attr
.select_type_temporary
13239 || sym
->ns
->save_all
13240 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13241 || sym
->ns
->proc_name
->attr
.is_main_program
13242 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13244 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13245 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13249 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13250 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13252 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13253 "deferred shape", sym
->name
, &sym
->declared_at
);
13256 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13257 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13259 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13260 "deferred shape", sym
->name
, &sym
->declared_at
);
13265 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13266 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13267 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13268 || (class_attr
.codimension
&& class_attr
.allocatable
))
13269 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13271 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13272 "allocatable coarray or have coarray components",
13273 sym
->name
, &sym
->declared_at
);
13277 if (class_attr
.codimension
&& sym
->attr
.dummy
13278 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13280 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13281 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13282 sym
->ns
->proc_name
->name
);
13286 if (sym
->ts
.type
== BT_LOGICAL
13287 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13288 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13289 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13292 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13293 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13295 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13296 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13297 "%L with non-C_Bool kind in BIND(C) procedure "
13298 "'%s'", sym
->name
, &sym
->declared_at
,
13299 sym
->ns
->proc_name
->name
))
13301 else if (!gfc_logical_kinds
[i
].c_bool
13302 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13303 "'%s' at %L with non-C_Bool kind in "
13304 "BIND(C) procedure '%s'", sym
->name
,
13306 sym
->attr
.function
? sym
->name
13307 : sym
->ns
->proc_name
->name
))
13311 switch (sym
->attr
.flavor
)
13314 if (!resolve_fl_variable (sym
, mp_flag
))
13319 if (!resolve_fl_procedure (sym
, mp_flag
))
13324 if (!resolve_fl_namelist (sym
))
13329 if (!resolve_fl_parameter (sym
))
13337 /* Resolve array specifier. Check as well some constraints
13338 on COMMON blocks. */
13340 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13342 /* Set the formal_arg_flag so that check_conflict will not throw
13343 an error for host associated variables in the specification
13344 expression for an array_valued function. */
13345 if (sym
->attr
.function
&& sym
->as
)
13346 formal_arg_flag
= 1;
13348 saved_specification_expr
= specification_expr
;
13349 specification_expr
= true;
13350 gfc_resolve_array_spec (sym
->as
, check_constant
);
13351 specification_expr
= saved_specification_expr
;
13353 formal_arg_flag
= 0;
13355 /* Resolve formal namespaces. */
13356 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13357 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13358 gfc_resolve (sym
->formal_ns
);
13360 /* Make sure the formal namespace is present. */
13361 if (sym
->formal
&& !sym
->formal_ns
)
13363 gfc_formal_arglist
*formal
= sym
->formal
;
13364 while (formal
&& !formal
->sym
)
13365 formal
= formal
->next
;
13369 sym
->formal_ns
= formal
->sym
->ns
;
13370 if (sym
->ns
!= formal
->sym
->ns
)
13371 sym
->formal_ns
->refs
++;
13375 /* Check threadprivate restrictions. */
13376 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13377 && (!sym
->attr
.in_common
13378 && sym
->module
== NULL
13379 && (sym
->ns
->proc_name
== NULL
13380 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13381 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13383 /* If we have come this far we can apply default-initializers, as
13384 described in 14.7.5, to those variables that have not already
13385 been assigned one. */
13386 if (sym
->ts
.type
== BT_DERIVED
13388 && !sym
->attr
.allocatable
13389 && !sym
->attr
.alloc_comp
)
13391 symbol_attribute
*a
= &sym
->attr
;
13393 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13394 && !a
->in_common
&& !a
->use_assoc
13395 && (a
->referenced
|| a
->result
)
13396 && !(a
->function
&& sym
!= sym
->result
))
13397 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13398 apply_default_init (sym
);
13401 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13402 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13403 && !CLASS_DATA (sym
)->attr
.class_pointer
13404 && !CLASS_DATA (sym
)->attr
.allocatable
)
13405 apply_default_init (sym
);
13407 /* If this symbol has a type-spec, check it. */
13408 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13409 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13410 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13415 /************* Resolve DATA statements *************/
13419 gfc_data_value
*vnode
;
13425 /* Advance the values structure to point to the next value in the data list. */
13428 next_data_value (void)
13430 while (mpz_cmp_ui (values
.left
, 0) == 0)
13433 if (values
.vnode
->next
== NULL
)
13436 values
.vnode
= values
.vnode
->next
;
13437 mpz_set (values
.left
, values
.vnode
->repeat
);
13445 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13451 ar_type mark
= AR_UNKNOWN
;
13453 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13459 if (!gfc_resolve_expr (var
->expr
))
13463 mpz_init_set_si (offset
, 0);
13466 if (e
->expr_type
!= EXPR_VARIABLE
)
13467 gfc_internal_error ("check_data_variable(): Bad expression");
13469 sym
= e
->symtree
->n
.sym
;
13471 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13473 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13474 sym
->name
, &sym
->declared_at
);
13477 if (e
->ref
== NULL
&& sym
->as
)
13479 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13480 " declaration", sym
->name
, where
);
13484 has_pointer
= sym
->attr
.pointer
;
13486 if (gfc_is_coindexed (e
))
13488 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13493 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13495 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13499 && ref
->type
== REF_ARRAY
13500 && ref
->u
.ar
.type
!= AR_FULL
)
13502 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13503 "be a full array", sym
->name
, where
);
13508 if (e
->rank
== 0 || has_pointer
)
13510 mpz_init_set_ui (size
, 1);
13517 /* Find the array section reference. */
13518 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13520 if (ref
->type
!= REF_ARRAY
)
13522 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13528 /* Set marks according to the reference pattern. */
13529 switch (ref
->u
.ar
.type
)
13537 /* Get the start position of array section. */
13538 gfc_get_section_index (ar
, section_index
, &offset
);
13543 gcc_unreachable ();
13546 if (!gfc_array_size (e
, &size
))
13548 gfc_error ("Nonconstant array section at %L in DATA statement",
13550 mpz_clear (offset
);
13557 while (mpz_cmp_ui (size
, 0) > 0)
13559 if (!next_data_value ())
13561 gfc_error ("DATA statement at %L has more variables than values",
13567 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13571 /* If we have more than one element left in the repeat count,
13572 and we have more than one element left in the target variable,
13573 then create a range assignment. */
13574 /* FIXME: Only done for full arrays for now, since array sections
13576 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13577 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13581 if (mpz_cmp (size
, values
.left
) >= 0)
13583 mpz_init_set (range
, values
.left
);
13584 mpz_sub (size
, size
, values
.left
);
13585 mpz_set_ui (values
.left
, 0);
13589 mpz_init_set (range
, size
);
13590 mpz_sub (values
.left
, values
.left
, size
);
13591 mpz_set_ui (size
, 0);
13594 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13597 mpz_add (offset
, offset
, range
);
13604 /* Assign initial value to symbol. */
13607 mpz_sub_ui (values
.left
, values
.left
, 1);
13608 mpz_sub_ui (size
, size
, 1);
13610 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13615 if (mark
== AR_FULL
)
13616 mpz_add_ui (offset
, offset
, 1);
13618 /* Modify the array section indexes and recalculate the offset
13619 for next element. */
13620 else if (mark
== AR_SECTION
)
13621 gfc_advance_section (section_index
, ar
, &offset
);
13625 if (mark
== AR_SECTION
)
13627 for (i
= 0; i
< ar
->dimen
; i
++)
13628 mpz_clear (section_index
[i
]);
13632 mpz_clear (offset
);
13638 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13640 /* Iterate over a list of elements in a DATA statement. */
13643 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13646 iterator_stack frame
;
13647 gfc_expr
*e
, *start
, *end
, *step
;
13648 bool retval
= true;
13650 mpz_init (frame
.value
);
13653 start
= gfc_copy_expr (var
->iter
.start
);
13654 end
= gfc_copy_expr (var
->iter
.end
);
13655 step
= gfc_copy_expr (var
->iter
.step
);
13657 if (!gfc_simplify_expr (start
, 1)
13658 || start
->expr_type
!= EXPR_CONSTANT
)
13660 gfc_error ("start of implied-do loop at %L could not be "
13661 "simplified to a constant value", &start
->where
);
13665 if (!gfc_simplify_expr (end
, 1)
13666 || end
->expr_type
!= EXPR_CONSTANT
)
13668 gfc_error ("end of implied-do loop at %L could not be "
13669 "simplified to a constant value", &start
->where
);
13673 if (!gfc_simplify_expr (step
, 1)
13674 || step
->expr_type
!= EXPR_CONSTANT
)
13676 gfc_error ("step of implied-do loop at %L could not be "
13677 "simplified to a constant value", &start
->where
);
13682 mpz_set (trip
, end
->value
.integer
);
13683 mpz_sub (trip
, trip
, start
->value
.integer
);
13684 mpz_add (trip
, trip
, step
->value
.integer
);
13686 mpz_div (trip
, trip
, step
->value
.integer
);
13688 mpz_set (frame
.value
, start
->value
.integer
);
13690 frame
.prev
= iter_stack
;
13691 frame
.variable
= var
->iter
.var
->symtree
;
13692 iter_stack
= &frame
;
13694 while (mpz_cmp_ui (trip
, 0) > 0)
13696 if (!traverse_data_var (var
->list
, where
))
13702 e
= gfc_copy_expr (var
->expr
);
13703 if (!gfc_simplify_expr (e
, 1))
13710 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13712 mpz_sub_ui (trip
, trip
, 1);
13716 mpz_clear (frame
.value
);
13719 gfc_free_expr (start
);
13720 gfc_free_expr (end
);
13721 gfc_free_expr (step
);
13723 iter_stack
= frame
.prev
;
13728 /* Type resolve variables in the variable list of a DATA statement. */
13731 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13735 for (; var
; var
= var
->next
)
13737 if (var
->expr
== NULL
)
13738 t
= traverse_data_list (var
, where
);
13740 t
= check_data_variable (var
, where
);
13750 /* Resolve the expressions and iterators associated with a data statement.
13751 This is separate from the assignment checking because data lists should
13752 only be resolved once. */
13755 resolve_data_variables (gfc_data_variable
*d
)
13757 for (; d
; d
= d
->next
)
13759 if (d
->list
== NULL
)
13761 if (!gfc_resolve_expr (d
->expr
))
13766 if (!gfc_resolve_iterator (&d
->iter
, false, true))
13769 if (!resolve_data_variables (d
->list
))
13778 /* Resolve a single DATA statement. We implement this by storing a pointer to
13779 the value list into static variables, and then recursively traversing the
13780 variables list, expanding iterators and such. */
13783 resolve_data (gfc_data
*d
)
13786 if (!resolve_data_variables (d
->var
))
13789 values
.vnode
= d
->value
;
13790 if (d
->value
== NULL
)
13791 mpz_set_ui (values
.left
, 0);
13793 mpz_set (values
.left
, d
->value
->repeat
);
13795 if (!traverse_data_var (d
->var
, &d
->where
))
13798 /* At this point, we better not have any values left. */
13800 if (next_data_value ())
13801 gfc_error ("DATA statement at %L has more values than variables",
13806 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13807 accessed by host or use association, is a dummy argument to a pure function,
13808 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13809 is storage associated with any such variable, shall not be used in the
13810 following contexts: (clients of this function). */
13812 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13813 procedure. Returns zero if assignment is OK, nonzero if there is a
13816 gfc_impure_variable (gfc_symbol
*sym
)
13821 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13824 /* Check if the symbol's ns is inside the pure procedure. */
13825 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13829 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13833 proc
= sym
->ns
->proc_name
;
13834 if (sym
->attr
.dummy
13835 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13836 || proc
->attr
.function
))
13839 /* TODO: Sort out what can be storage associated, if anything, and include
13840 it here. In principle equivalences should be scanned but it does not
13841 seem to be possible to storage associate an impure variable this way. */
13846 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13847 current namespace is inside a pure procedure. */
13850 gfc_pure (gfc_symbol
*sym
)
13852 symbol_attribute attr
;
13857 /* Check if the current namespace or one of its parents
13858 belongs to a pure procedure. */
13859 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13861 sym
= ns
->proc_name
;
13865 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13873 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13877 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13878 checks if the current namespace is implicitly pure. Note that this
13879 function returns false for a PURE procedure. */
13882 gfc_implicit_pure (gfc_symbol
*sym
)
13888 /* Check if the current procedure is implicit_pure. Walk up
13889 the procedure list until we find a procedure. */
13890 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13892 sym
= ns
->proc_name
;
13896 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13901 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13902 && !sym
->attr
.pure
;
13906 /* Test whether the current procedure is elemental or not. */
13909 gfc_elemental (gfc_symbol
*sym
)
13911 symbol_attribute attr
;
13914 sym
= gfc_current_ns
->proc_name
;
13919 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13923 /* Warn about unused labels. */
13926 warn_unused_fortran_label (gfc_st_label
*label
)
13931 warn_unused_fortran_label (label
->left
);
13933 if (label
->defined
== ST_LABEL_UNKNOWN
)
13936 switch (label
->referenced
)
13938 case ST_LABEL_UNKNOWN
:
13939 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13943 case ST_LABEL_BAD_TARGET
:
13944 gfc_warning ("Label %d at %L defined but cannot be used",
13945 label
->value
, &label
->where
);
13952 warn_unused_fortran_label (label
->right
);
13956 /* Returns the sequence type of a symbol or sequence. */
13959 sequence_type (gfc_typespec ts
)
13968 if (ts
.u
.derived
->components
== NULL
)
13969 return SEQ_NONDEFAULT
;
13971 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13972 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13973 if (sequence_type (c
->ts
) != result
)
13979 if (ts
.kind
!= gfc_default_character_kind
)
13980 return SEQ_NONDEFAULT
;
13982 return SEQ_CHARACTER
;
13985 if (ts
.kind
!= gfc_default_integer_kind
)
13986 return SEQ_NONDEFAULT
;
13988 return SEQ_NUMERIC
;
13991 if (!(ts
.kind
== gfc_default_real_kind
13992 || ts
.kind
== gfc_default_double_kind
))
13993 return SEQ_NONDEFAULT
;
13995 return SEQ_NUMERIC
;
13998 if (ts
.kind
!= gfc_default_complex_kind
)
13999 return SEQ_NONDEFAULT
;
14001 return SEQ_NUMERIC
;
14004 if (ts
.kind
!= gfc_default_logical_kind
)
14005 return SEQ_NONDEFAULT
;
14007 return SEQ_NUMERIC
;
14010 return SEQ_NONDEFAULT
;
14015 /* Resolve derived type EQUIVALENCE object. */
14018 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14020 gfc_component
*c
= derived
->components
;
14025 /* Shall not be an object of nonsequence derived type. */
14026 if (!derived
->attr
.sequence
)
14028 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14029 "attribute to be an EQUIVALENCE object", sym
->name
,
14034 /* Shall not have allocatable components. */
14035 if (derived
->attr
.alloc_comp
)
14037 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14038 "components to be an EQUIVALENCE object",sym
->name
,
14043 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14045 gfc_error ("Derived type variable '%s' at %L with default "
14046 "initialization cannot be in EQUIVALENCE with a variable "
14047 "in COMMON", sym
->name
, &e
->where
);
14051 for (; c
; c
= c
->next
)
14053 if (c
->ts
.type
== BT_DERIVED
14054 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14057 /* Shall not be an object of sequence derived type containing a pointer
14058 in the structure. */
14059 if (c
->attr
.pointer
)
14061 gfc_error ("Derived type variable '%s' at %L with pointer "
14062 "component(s) cannot be an EQUIVALENCE object",
14063 sym
->name
, &e
->where
);
14071 /* Resolve equivalence object.
14072 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14073 an allocatable array, an object of nonsequence derived type, an object of
14074 sequence derived type containing a pointer at any level of component
14075 selection, an automatic object, a function name, an entry name, a result
14076 name, a named constant, a structure component, or a subobject of any of
14077 the preceding objects. A substring shall not have length zero. A
14078 derived type shall not have components with default initialization nor
14079 shall two objects of an equivalence group be initialized.
14080 Either all or none of the objects shall have an protected attribute.
14081 The simple constraints are done in symbol.c(check_conflict) and the rest
14082 are implemented here. */
14085 resolve_equivalence (gfc_equiv
*eq
)
14088 gfc_symbol
*first_sym
;
14091 locus
*last_where
= NULL
;
14092 seq_type eq_type
, last_eq_type
;
14093 gfc_typespec
*last_ts
;
14094 int object
, cnt_protected
;
14097 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14099 first_sym
= eq
->expr
->symtree
->n
.sym
;
14103 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14107 e
->ts
= e
->symtree
->n
.sym
->ts
;
14108 /* match_varspec might not know yet if it is seeing
14109 array reference or substring reference, as it doesn't
14111 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14113 gfc_ref
*ref
= e
->ref
;
14114 sym
= e
->symtree
->n
.sym
;
14116 if (sym
->attr
.dimension
)
14118 ref
->u
.ar
.as
= sym
->as
;
14122 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14123 if (e
->ts
.type
== BT_CHARACTER
14125 && ref
->type
== REF_ARRAY
14126 && ref
->u
.ar
.dimen
== 1
14127 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14128 && ref
->u
.ar
.stride
[0] == NULL
)
14130 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14131 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14134 /* Optimize away the (:) reference. */
14135 if (start
== NULL
&& end
== NULL
)
14138 e
->ref
= ref
->next
;
14140 e
->ref
->next
= ref
->next
;
14145 ref
->type
= REF_SUBSTRING
;
14147 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14149 ref
->u
.ss
.start
= start
;
14150 if (end
== NULL
&& e
->ts
.u
.cl
)
14151 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14152 ref
->u
.ss
.end
= end
;
14153 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14160 /* Any further ref is an error. */
14163 gcc_assert (ref
->type
== REF_ARRAY
);
14164 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14170 if (!gfc_resolve_expr (e
))
14173 sym
= e
->symtree
->n
.sym
;
14175 if (sym
->attr
.is_protected
)
14177 if (cnt_protected
> 0 && cnt_protected
!= object
)
14179 gfc_error ("Either all or none of the objects in the "
14180 "EQUIVALENCE set at %L shall have the "
14181 "PROTECTED attribute",
14186 /* Shall not equivalence common block variables in a PURE procedure. */
14187 if (sym
->ns
->proc_name
14188 && sym
->ns
->proc_name
->attr
.pure
14189 && sym
->attr
.in_common
)
14191 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14192 "object in the pure procedure '%s'",
14193 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14197 /* Shall not be a named constant. */
14198 if (e
->expr_type
== EXPR_CONSTANT
)
14200 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14201 "object", sym
->name
, &e
->where
);
14205 if (e
->ts
.type
== BT_DERIVED
14206 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14209 /* Check that the types correspond correctly:
14211 A numeric sequence structure may be equivalenced to another sequence
14212 structure, an object of default integer type, default real type, double
14213 precision real type, default logical type such that components of the
14214 structure ultimately only become associated to objects of the same
14215 kind. A character sequence structure may be equivalenced to an object
14216 of default character kind or another character sequence structure.
14217 Other objects may be equivalenced only to objects of the same type and
14218 kind parameters. */
14220 /* Identical types are unconditionally OK. */
14221 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14222 goto identical_types
;
14224 last_eq_type
= sequence_type (*last_ts
);
14225 eq_type
= sequence_type (sym
->ts
);
14227 /* Since the pair of objects is not of the same type, mixed or
14228 non-default sequences can be rejected. */
14230 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14231 "statement at %L with different type objects";
14233 && last_eq_type
== SEQ_MIXED
14234 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14235 || (eq_type
== SEQ_MIXED
14236 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14239 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14240 "statement at %L with objects of different type";
14242 && last_eq_type
== SEQ_NONDEFAULT
14243 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14244 || (eq_type
== SEQ_NONDEFAULT
14245 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14248 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14249 "EQUIVALENCE statement at %L";
14250 if (last_eq_type
== SEQ_CHARACTER
14251 && eq_type
!= SEQ_CHARACTER
14252 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14255 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14256 "EQUIVALENCE statement at %L";
14257 if (last_eq_type
== SEQ_NUMERIC
14258 && eq_type
!= SEQ_NUMERIC
14259 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14264 last_where
= &e
->where
;
14269 /* Shall not be an automatic array. */
14270 if (e
->ref
->type
== REF_ARRAY
14271 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14273 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14274 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14281 /* Shall not be a structure component. */
14282 if (r
->type
== REF_COMPONENT
)
14284 gfc_error ("Structure component '%s' at %L cannot be an "
14285 "EQUIVALENCE object",
14286 r
->u
.c
.component
->name
, &e
->where
);
14290 /* A substring shall not have length zero. */
14291 if (r
->type
== REF_SUBSTRING
)
14293 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14295 gfc_error ("Substring at %L has length zero",
14296 &r
->u
.ss
.start
->where
);
14306 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14309 resolve_fntype (gfc_namespace
*ns
)
14311 gfc_entry_list
*el
;
14314 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14317 /* If there are any entries, ns->proc_name is the entry master
14318 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14320 sym
= ns
->entries
->sym
;
14322 sym
= ns
->proc_name
;
14323 if (sym
->result
== sym
14324 && sym
->ts
.type
== BT_UNKNOWN
14325 && !gfc_set_default_type (sym
, 0, NULL
)
14326 && !sym
->attr
.untyped
)
14328 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14329 sym
->name
, &sym
->declared_at
);
14330 sym
->attr
.untyped
= 1;
14333 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14334 && !sym
->attr
.contained
14335 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14336 && gfc_check_symbol_access (sym
))
14338 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14339 "%L of PRIVATE type '%s'", sym
->name
,
14340 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14344 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14346 if (el
->sym
->result
== el
->sym
14347 && el
->sym
->ts
.type
== BT_UNKNOWN
14348 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14349 && !el
->sym
->attr
.untyped
)
14351 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14352 el
->sym
->name
, &el
->sym
->declared_at
);
14353 el
->sym
->attr
.untyped
= 1;
14359 /* 12.3.2.1.1 Defined operators. */
14362 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14364 gfc_formal_arglist
*formal
;
14366 if (!sym
->attr
.function
)
14368 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14369 sym
->name
, &where
);
14373 if (sym
->ts
.type
== BT_CHARACTER
14374 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14375 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14376 && sym
->result
->ts
.u
.cl
->length
))
14378 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14379 "character length", sym
->name
, &where
);
14383 formal
= gfc_sym_get_dummy_args (sym
);
14384 if (!formal
|| !formal
->sym
)
14386 gfc_error ("User operator procedure '%s' at %L must have at least "
14387 "one argument", sym
->name
, &where
);
14391 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14393 gfc_error ("First argument of operator interface at %L must be "
14394 "INTENT(IN)", &where
);
14398 if (formal
->sym
->attr
.optional
)
14400 gfc_error ("First argument of operator interface at %L cannot be "
14401 "optional", &where
);
14405 formal
= formal
->next
;
14406 if (!formal
|| !formal
->sym
)
14409 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14411 gfc_error ("Second argument of operator interface at %L must be "
14412 "INTENT(IN)", &where
);
14416 if (formal
->sym
->attr
.optional
)
14418 gfc_error ("Second argument of operator interface at %L cannot be "
14419 "optional", &where
);
14425 gfc_error ("Operator interface at %L must have, at most, two "
14426 "arguments", &where
);
14434 gfc_resolve_uops (gfc_symtree
*symtree
)
14436 gfc_interface
*itr
;
14438 if (symtree
== NULL
)
14441 gfc_resolve_uops (symtree
->left
);
14442 gfc_resolve_uops (symtree
->right
);
14444 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14445 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14449 /* Examine all of the expressions associated with a program unit,
14450 assign types to all intermediate expressions, make sure that all
14451 assignments are to compatible types and figure out which names
14452 refer to which functions or subroutines. It doesn't check code
14453 block, which is handled by resolve_code. */
14456 resolve_types (gfc_namespace
*ns
)
14462 gfc_namespace
* old_ns
= gfc_current_ns
;
14464 /* Check that all IMPLICIT types are ok. */
14465 if (!ns
->seen_implicit_none
)
14468 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14469 if (ns
->set_flag
[letter
]
14470 && !resolve_typespec_used (&ns
->default_type
[letter
],
14471 &ns
->implicit_loc
[letter
], NULL
))
14475 gfc_current_ns
= ns
;
14477 resolve_entries (ns
);
14479 resolve_common_vars (ns
->blank_common
.head
, false);
14480 resolve_common_blocks (ns
->common_root
);
14482 resolve_contained_functions (ns
);
14484 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14485 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14486 resolve_formal_arglist (ns
->proc_name
);
14488 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14490 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14491 resolve_charlen (cl
);
14493 gfc_traverse_ns (ns
, resolve_symbol
);
14495 resolve_fntype (ns
);
14497 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14499 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14500 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14501 "also be PURE", n
->proc_name
->name
,
14502 &n
->proc_name
->declared_at
);
14508 gfc_do_concurrent_flag
= 0;
14509 gfc_check_interfaces (ns
);
14511 gfc_traverse_ns (ns
, resolve_values
);
14517 for (d
= ns
->data
; d
; d
= d
->next
)
14521 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14523 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14525 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14526 resolve_equivalence (eq
);
14528 /* Warn about unused labels. */
14529 if (warn_unused_label
)
14530 warn_unused_fortran_label (ns
->st_labels
);
14532 gfc_resolve_uops (ns
->uop_root
);
14534 gfc_current_ns
= old_ns
;
14538 /* Call resolve_code recursively. */
14541 resolve_codes (gfc_namespace
*ns
)
14544 bitmap_obstack old_obstack
;
14546 if (ns
->resolved
== 1)
14549 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14552 gfc_current_ns
= ns
;
14554 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14555 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14558 /* Set to an out of range value. */
14559 current_entry_id
= -1;
14561 old_obstack
= labels_obstack
;
14562 bitmap_obstack_initialize (&labels_obstack
);
14564 resolve_code (ns
->code
, ns
);
14566 bitmap_obstack_release (&labels_obstack
);
14567 labels_obstack
= old_obstack
;
14571 /* This function is called after a complete program unit has been compiled.
14572 Its purpose is to examine all of the expressions associated with a program
14573 unit, assign types to all intermediate expressions, make sure that all
14574 assignments are to compatible types and figure out which names refer to
14575 which functions or subroutines. */
14578 gfc_resolve (gfc_namespace
*ns
)
14580 gfc_namespace
*old_ns
;
14581 code_stack
*old_cs_base
;
14587 old_ns
= gfc_current_ns
;
14588 old_cs_base
= cs_base
;
14590 resolve_types (ns
);
14591 component_assignment_level
= 0;
14592 resolve_codes (ns
);
14594 gfc_current_ns
= old_ns
;
14595 cs_base
= old_cs_base
;
14598 gfc_run_passes (ns
);