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 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1332 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1333 || gfc_is_coindexed (cons
->expr
));
1334 if (impure
&& gfc_pure (NULL
))
1337 gfc_error ("Invalid expression in the structure constructor for "
1338 "pointer component '%s' at %L in PURE procedure",
1339 comp
->name
, &cons
->expr
->where
);
1343 gfc_unset_implicit_pure (NULL
);
1350 /****************** Expression name resolution ******************/
1352 /* Returns 0 if a symbol was not declared with a type or
1353 attribute declaration statement, nonzero otherwise. */
1356 was_declared (gfc_symbol
*sym
)
1362 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1365 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1366 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1367 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1368 || a
.asynchronous
|| a
.codimension
)
1375 /* Determine if a symbol is generic or not. */
1378 generic_sym (gfc_symbol
*sym
)
1382 if (sym
->attr
.generic
||
1383 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1386 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1389 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1396 return generic_sym (s
);
1403 /* Determine if a symbol is specific or not. */
1406 specific_sym (gfc_symbol
*sym
)
1410 if (sym
->attr
.if_source
== IFSRC_IFBODY
1411 || sym
->attr
.proc
== PROC_MODULE
1412 || sym
->attr
.proc
== PROC_INTERNAL
1413 || sym
->attr
.proc
== PROC_ST_FUNCTION
1414 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1415 || sym
->attr
.external
)
1418 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1421 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1423 return (s
== NULL
) ? 0 : specific_sym (s
);
1427 /* Figure out if the procedure is specific, generic or unknown. */
1430 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1434 procedure_kind (gfc_symbol
*sym
)
1436 if (generic_sym (sym
))
1437 return PTYPE_GENERIC
;
1439 if (specific_sym (sym
))
1440 return PTYPE_SPECIFIC
;
1442 return PTYPE_UNKNOWN
;
1445 /* Check references to assumed size arrays. The flag need_full_assumed_size
1446 is nonzero when matching actual arguments. */
1448 static int need_full_assumed_size
= 0;
1451 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1453 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1456 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1457 What should it be? */
1458 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1459 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1460 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1462 gfc_error ("The upper bound in the last dimension must "
1463 "appear in the reference to the assumed size "
1464 "array '%s' at %L", sym
->name
, &e
->where
);
1471 /* Look for bad assumed size array references in argument expressions
1472 of elemental and array valued intrinsic procedures. Since this is
1473 called from procedure resolution functions, it only recurses at
1477 resolve_assumed_size_actual (gfc_expr
*e
)
1482 switch (e
->expr_type
)
1485 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1490 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1491 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1502 /* Check a generic procedure, passed as an actual argument, to see if
1503 there is a matching specific name. If none, it is an error, and if
1504 more than one, the reference is ambiguous. */
1506 count_specific_procs (gfc_expr
*e
)
1513 sym
= e
->symtree
->n
.sym
;
1515 for (p
= sym
->generic
; p
; p
= p
->next
)
1516 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1518 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1524 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1528 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1529 "argument at %L", sym
->name
, &e
->where
);
1535 /* See if a call to sym could possibly be a not allowed RECURSION because of
1536 a missing RECURSIVE declaration. This means that either sym is the current
1537 context itself, or sym is the parent of a contained procedure calling its
1538 non-RECURSIVE containing procedure.
1539 This also works if sym is an ENTRY. */
1542 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1544 gfc_symbol
* proc_sym
;
1545 gfc_symbol
* context_proc
;
1546 gfc_namespace
* real_context
;
1548 if (sym
->attr
.flavor
== FL_PROGRAM
1549 || sym
->attr
.flavor
== FL_DERIVED
)
1552 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1554 /* If we've got an ENTRY, find real procedure. */
1555 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1556 proc_sym
= sym
->ns
->entries
->sym
;
1560 /* If sym is RECURSIVE, all is well of course. */
1561 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1564 /* Find the context procedure's "real" symbol if it has entries.
1565 We look for a procedure symbol, so recurse on the parents if we don't
1566 find one (like in case of a BLOCK construct). */
1567 for (real_context
= context
; ; real_context
= real_context
->parent
)
1569 /* We should find something, eventually! */
1570 gcc_assert (real_context
);
1572 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1573 : real_context
->proc_name
);
1575 /* In some special cases, there may not be a proc_name, like for this
1577 real(bad_kind()) function foo () ...
1578 when checking the call to bad_kind ().
1579 In these cases, we simply return here and assume that the
1584 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1588 /* A call from sym's body to itself is recursion, of course. */
1589 if (context_proc
== proc_sym
)
1592 /* The same is true if context is a contained procedure and sym the
1594 if (context_proc
->attr
.contained
)
1596 gfc_symbol
* parent_proc
;
1598 gcc_assert (context
->parent
);
1599 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1600 : context
->parent
->proc_name
);
1602 if (parent_proc
== proc_sym
)
1610 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1611 its typespec and formal argument list. */
1614 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1616 gfc_intrinsic_sym
* isym
= NULL
;
1622 /* Already resolved. */
1623 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1626 /* We already know this one is an intrinsic, so we don't call
1627 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1628 gfc_find_subroutine directly to check whether it is a function or
1631 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1633 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1634 isym
= gfc_intrinsic_subroutine_by_id (id
);
1636 else if (sym
->intmod_sym_id
)
1638 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1639 isym
= gfc_intrinsic_function_by_id (id
);
1641 else if (!sym
->attr
.subroutine
)
1642 isym
= gfc_find_function (sym
->name
);
1644 if (isym
&& !sym
->attr
.subroutine
)
1646 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1647 && !sym
->attr
.implicit_type
)
1648 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1649 " ignored", sym
->name
, &sym
->declared_at
);
1651 if (!sym
->attr
.function
&&
1652 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1657 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1659 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1661 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1662 " specifier", sym
->name
, &sym
->declared_at
);
1666 if (!sym
->attr
.subroutine
&&
1667 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1672 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1677 gfc_copy_formal_args_intr (sym
, isym
);
1679 sym
->attr
.pure
= isym
->pure
;
1680 sym
->attr
.elemental
= isym
->elemental
;
1682 /* Check it is actually available in the standard settings. */
1683 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1685 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1686 " available in the current standard settings but %s. Use"
1687 " an appropriate -std=* option or enable -fall-intrinsics"
1688 " in order to use it.",
1689 sym
->name
, &sym
->declared_at
, symstd
);
1697 /* Resolve a procedure expression, like passing it to a called procedure or as
1698 RHS for a procedure pointer assignment. */
1701 resolve_procedure_expression (gfc_expr
* expr
)
1705 if (expr
->expr_type
!= EXPR_VARIABLE
)
1707 gcc_assert (expr
->symtree
);
1709 sym
= expr
->symtree
->n
.sym
;
1711 if (sym
->attr
.intrinsic
)
1712 gfc_resolve_intrinsic (sym
, &expr
->where
);
1714 if (sym
->attr
.flavor
!= FL_PROCEDURE
1715 || (sym
->attr
.function
&& sym
->result
== sym
))
1718 /* A non-RECURSIVE procedure that is used as procedure expression within its
1719 own body is in danger of being called recursively. */
1720 if (is_illegal_recursion (sym
, gfc_current_ns
))
1721 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1722 " itself recursively. Declare it RECURSIVE or use"
1723 " -frecursive", sym
->name
, &expr
->where
);
1729 /* Resolve an actual argument list. Most of the time, this is just
1730 resolving the expressions in the list.
1731 The exception is that we sometimes have to decide whether arguments
1732 that look like procedure arguments are really simple variable
1736 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1737 bool no_formal_args
)
1740 gfc_symtree
*parent_st
;
1742 int save_need_full_assumed_size
;
1743 bool return_value
= false;
1744 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1747 first_actual_arg
= true;
1749 for (; arg
; arg
= arg
->next
)
1754 /* Check the label is a valid branching target. */
1757 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1759 gfc_error ("Label %d referenced at %L is never defined",
1760 arg
->label
->value
, &arg
->label
->where
);
1764 first_actual_arg
= false;
1768 if (e
->expr_type
== EXPR_VARIABLE
1769 && e
->symtree
->n
.sym
->attr
.generic
1771 && count_specific_procs (e
) != 1)
1774 if (e
->ts
.type
!= BT_PROCEDURE
)
1776 save_need_full_assumed_size
= need_full_assumed_size
;
1777 if (e
->expr_type
!= EXPR_VARIABLE
)
1778 need_full_assumed_size
= 0;
1779 if (!gfc_resolve_expr (e
))
1781 need_full_assumed_size
= save_need_full_assumed_size
;
1785 /* See if the expression node should really be a variable reference. */
1787 sym
= e
->symtree
->n
.sym
;
1789 if (sym
->attr
.flavor
== FL_PROCEDURE
1790 || sym
->attr
.intrinsic
1791 || sym
->attr
.external
)
1795 /* If a procedure is not already determined to be something else
1796 check if it is intrinsic. */
1797 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1798 sym
->attr
.intrinsic
= 1;
1800 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1802 gfc_error ("Statement function '%s' at %L is not allowed as an "
1803 "actual argument", sym
->name
, &e
->where
);
1806 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1807 sym
->attr
.subroutine
);
1808 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1810 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1811 "actual argument", sym
->name
, &e
->where
);
1814 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1815 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1817 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is"
1818 " used as actual argument at %L",
1819 sym
->name
, &e
->where
))
1823 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1825 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1826 "allowed as an actual argument at %L", sym
->name
,
1830 /* Check if a generic interface has a specific procedure
1831 with the same name before emitting an error. */
1832 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1835 /* Just in case a specific was found for the expression. */
1836 sym
= e
->symtree
->n
.sym
;
1838 /* If the symbol is the function that names the current (or
1839 parent) scope, then we really have a variable reference. */
1841 if (gfc_is_function_return_value (sym
, sym
->ns
))
1844 /* If all else fails, see if we have a specific intrinsic. */
1845 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1847 gfc_intrinsic_sym
*isym
;
1849 isym
= gfc_find_function (sym
->name
);
1850 if (isym
== NULL
|| !isym
->specific
)
1852 gfc_error ("Unable to find a specific INTRINSIC procedure "
1853 "for the reference '%s' at %L", sym
->name
,
1858 sym
->attr
.intrinsic
= 1;
1859 sym
->attr
.function
= 1;
1862 if (!gfc_resolve_expr (e
))
1867 /* See if the name is a module procedure in a parent unit. */
1869 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1872 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1874 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1878 if (parent_st
== NULL
)
1881 sym
= parent_st
->n
.sym
;
1882 e
->symtree
= parent_st
; /* Point to the right thing. */
1884 if (sym
->attr
.flavor
== FL_PROCEDURE
1885 || sym
->attr
.intrinsic
1886 || sym
->attr
.external
)
1888 if (!gfc_resolve_expr (e
))
1894 e
->expr_type
= EXPR_VARIABLE
;
1896 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1897 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1898 && CLASS_DATA (sym
)->as
))
1900 e
->rank
= sym
->ts
.type
== BT_CLASS
1901 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1902 e
->ref
= gfc_get_ref ();
1903 e
->ref
->type
= REF_ARRAY
;
1904 e
->ref
->u
.ar
.type
= AR_FULL
;
1905 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1906 ? CLASS_DATA (sym
)->as
: sym
->as
;
1909 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1910 primary.c (match_actual_arg). If above code determines that it
1911 is a variable instead, it needs to be resolved as it was not
1912 done at the beginning of this function. */
1913 save_need_full_assumed_size
= need_full_assumed_size
;
1914 if (e
->expr_type
!= EXPR_VARIABLE
)
1915 need_full_assumed_size
= 0;
1916 if (!gfc_resolve_expr (e
))
1918 need_full_assumed_size
= save_need_full_assumed_size
;
1921 /* Check argument list functions %VAL, %LOC and %REF. There is
1922 nothing to do for %REF. */
1923 if (arg
->name
&& arg
->name
[0] == '%')
1925 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1927 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1929 gfc_error ("By-value argument at %L is not of numeric "
1936 gfc_error ("By-value argument at %L cannot be an array or "
1937 "an array section", &e
->where
);
1941 /* Intrinsics are still PROC_UNKNOWN here. However,
1942 since same file external procedures are not resolvable
1943 in gfortran, it is a good deal easier to leave them to
1945 if (ptype
!= PROC_UNKNOWN
1946 && ptype
!= PROC_DUMMY
1947 && ptype
!= PROC_EXTERNAL
1948 && ptype
!= PROC_MODULE
)
1950 gfc_error ("By-value argument at %L is not allowed "
1951 "in this context", &e
->where
);
1956 /* Statement functions have already been excluded above. */
1957 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1958 && e
->ts
.type
== BT_PROCEDURE
)
1960 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1962 gfc_error ("Passing internal procedure at %L by location "
1963 "not allowed", &e
->where
);
1969 /* Fortran 2008, C1237. */
1970 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1971 && gfc_has_ultimate_pointer (e
))
1973 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1974 "component", &e
->where
);
1978 first_actual_arg
= false;
1981 return_value
= true;
1984 actual_arg
= actual_arg_sav
;
1985 first_actual_arg
= first_actual_arg_sav
;
1987 return return_value
;
1991 /* Do the checks of the actual argument list that are specific to elemental
1992 procedures. If called with c == NULL, we have a function, otherwise if
1993 expr == NULL, we have a subroutine. */
1996 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1998 gfc_actual_arglist
*arg0
;
1999 gfc_actual_arglist
*arg
;
2000 gfc_symbol
*esym
= NULL
;
2001 gfc_intrinsic_sym
*isym
= NULL
;
2003 gfc_intrinsic_arg
*iformal
= NULL
;
2004 gfc_formal_arglist
*eformal
= NULL
;
2005 bool formal_optional
= false;
2006 bool set_by_optional
= false;
2010 /* Is this an elemental procedure? */
2011 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2013 if (expr
->value
.function
.esym
!= NULL
2014 && expr
->value
.function
.esym
->attr
.elemental
)
2016 arg0
= expr
->value
.function
.actual
;
2017 esym
= expr
->value
.function
.esym
;
2019 else if (expr
->value
.function
.isym
!= NULL
2020 && expr
->value
.function
.isym
->elemental
)
2022 arg0
= expr
->value
.function
.actual
;
2023 isym
= expr
->value
.function
.isym
;
2028 else if (c
&& c
->ext
.actual
!= NULL
)
2030 arg0
= c
->ext
.actual
;
2032 if (c
->resolved_sym
)
2033 esym
= c
->resolved_sym
;
2035 esym
= c
->symtree
->n
.sym
;
2038 if (!esym
->attr
.elemental
)
2044 /* The rank of an elemental is the rank of its array argument(s). */
2045 for (arg
= arg0
; arg
; arg
= arg
->next
)
2047 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2049 rank
= arg
->expr
->rank
;
2050 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2051 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2052 set_by_optional
= true;
2054 /* Function specific; set the result rank and shape. */
2058 if (!expr
->shape
&& arg
->expr
->shape
)
2060 expr
->shape
= gfc_get_shape (rank
);
2061 for (i
= 0; i
< rank
; i
++)
2062 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2069 /* If it is an array, it shall not be supplied as an actual argument
2070 to an elemental procedure unless an array of the same rank is supplied
2071 as an actual argument corresponding to a nonoptional dummy argument of
2072 that elemental procedure(12.4.1.5). */
2073 formal_optional
= false;
2075 iformal
= isym
->formal
;
2077 eformal
= esym
->formal
;
2079 for (arg
= arg0
; arg
; arg
= arg
->next
)
2083 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2084 formal_optional
= true;
2085 eformal
= eformal
->next
;
2087 else if (isym
&& iformal
)
2089 if (iformal
->optional
)
2090 formal_optional
= true;
2091 iformal
= iformal
->next
;
2094 formal_optional
= true;
2096 if (pedantic
&& arg
->expr
!= NULL
2097 && arg
->expr
->expr_type
== EXPR_VARIABLE
2098 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2101 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2102 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2104 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2105 "MISSING, it cannot be the actual argument of an "
2106 "ELEMENTAL procedure unless there is a non-optional "
2107 "argument with the same rank (12.4.1.5)",
2108 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2112 for (arg
= arg0
; arg
; arg
= arg
->next
)
2114 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2117 /* Being elemental, the last upper bound of an assumed size array
2118 argument must be present. */
2119 if (resolve_assumed_size_actual (arg
->expr
))
2122 /* Elemental procedure's array actual arguments must conform. */
2125 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2132 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2133 is an array, the intent inout/out variable needs to be also an array. */
2134 if (rank
> 0 && esym
&& expr
== NULL
)
2135 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2136 arg
= arg
->next
, eformal
= eformal
->next
)
2137 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2138 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2139 && arg
->expr
&& arg
->expr
->rank
== 0)
2141 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2142 "ELEMENTAL subroutine '%s' is a scalar, but another "
2143 "actual argument is an array", &arg
->expr
->where
,
2144 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2145 : "INOUT", eformal
->sym
->name
, esym
->name
);
2152 /* This function does the checking of references to global procedures
2153 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2154 77 and 95 standards. It checks for a gsymbol for the name, making
2155 one if it does not already exist. If it already exists, then the
2156 reference being resolved must correspond to the type of gsymbol.
2157 Otherwise, the new symbol is equipped with the attributes of the
2158 reference. The corresponding code that is called in creating
2159 global entities is parse.c.
2161 In addition, for all but -std=legacy, the gsymbols are used to
2162 check the interfaces of external procedures from the same file.
2163 The namespace of the gsymbol is resolved and then, once this is
2164 done the interface is checked. */
2168 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2170 if (!gsym_ns
->proc_name
->attr
.recursive
)
2173 if (sym
->ns
== gsym_ns
)
2176 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2183 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2185 if (gsym_ns
->entries
)
2187 gfc_entry_list
*entry
= gsym_ns
->entries
;
2189 for (; entry
; entry
= entry
->next
)
2191 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2193 if (strcmp (gsym_ns
->proc_name
->name
,
2194 sym
->ns
->proc_name
->name
) == 0)
2198 && strcmp (gsym_ns
->proc_name
->name
,
2199 sym
->ns
->parent
->proc_name
->name
) == 0)
2208 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2211 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2213 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2215 for ( ; arg
; arg
= arg
->next
)
2220 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2222 strncpy (errmsg
, _("allocatable argument"), err_len
);
2225 else if (arg
->sym
->attr
.asynchronous
)
2227 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2230 else if (arg
->sym
->attr
.optional
)
2232 strncpy (errmsg
, _("optional argument"), err_len
);
2235 else if (arg
->sym
->attr
.pointer
)
2237 strncpy (errmsg
, _("pointer argument"), err_len
);
2240 else if (arg
->sym
->attr
.target
)
2242 strncpy (errmsg
, _("target argument"), err_len
);
2245 else if (arg
->sym
->attr
.value
)
2247 strncpy (errmsg
, _("value argument"), err_len
);
2250 else if (arg
->sym
->attr
.volatile_
)
2252 strncpy (errmsg
, _("volatile argument"), err_len
);
2255 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2257 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2260 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2262 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2265 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2267 strncpy (errmsg
, _("coarray argument"), err_len
);
2270 else if (false) /* (2d) TODO: parametrized derived type */
2272 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2275 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2277 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2280 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2282 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2285 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2287 /* As assumed-type is unlimited polymorphic (cf. above).
2288 See also TS 29113, Note 6.1. */
2289 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2294 if (sym
->attr
.function
)
2296 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2298 if (res
->attr
.dimension
) /* (3a) */
2300 strncpy (errmsg
, _("array result"), err_len
);
2303 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2305 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2308 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2309 && res
->ts
.u
.cl
->length
2310 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2312 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2317 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2319 strncpy (errmsg
, _("elemental procedure"), err_len
);
2322 else if (sym
->attr
.is_bind_c
) /* (5) */
2324 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2333 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2334 gfc_actual_arglist
**actual
, int sub
)
2338 enum gfc_symbol_type type
;
2341 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2343 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2345 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2346 gfc_global_used (gsym
, where
);
2348 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2349 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2350 && gsym
->type
!= GSYM_UNKNOWN
2351 && !gsym
->binding_label
2353 && gsym
->ns
->resolved
!= -1
2354 && gsym
->ns
->proc_name
2355 && not_in_recursive (sym
, gsym
->ns
)
2356 && not_entry_self_reference (sym
, gsym
->ns
))
2358 gfc_symbol
*def_sym
;
2360 /* Resolve the gsymbol namespace if needed. */
2361 if (!gsym
->ns
->resolved
)
2363 gfc_dt_list
*old_dt_list
;
2364 struct gfc_omp_saved_state old_omp_state
;
2366 /* Stash away derived types so that the backend_decls do not
2368 old_dt_list
= gfc_derived_types
;
2369 gfc_derived_types
= NULL
;
2370 /* And stash away openmp state. */
2371 gfc_omp_save_and_clear_state (&old_omp_state
);
2373 gfc_resolve (gsym
->ns
);
2375 /* Store the new derived types with the global namespace. */
2376 if (gfc_derived_types
)
2377 gsym
->ns
->derived_types
= gfc_derived_types
;
2379 /* Restore the derived types of this namespace. */
2380 gfc_derived_types
= old_dt_list
;
2381 /* And openmp state. */
2382 gfc_omp_restore_state (&old_omp_state
);
2385 /* Make sure that translation for the gsymbol occurs before
2386 the procedure currently being resolved. */
2387 ns
= gfc_global_ns_list
;
2388 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2390 if (ns
->sibling
== gsym
->ns
)
2392 ns
->sibling
= gsym
->ns
->sibling
;
2393 gsym
->ns
->sibling
= gfc_global_ns_list
;
2394 gfc_global_ns_list
= gsym
->ns
;
2399 def_sym
= gsym
->ns
->proc_name
;
2401 /* This can happen if a binding name has been specified. */
2402 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2403 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2405 if (def_sym
->attr
.entry_master
)
2407 gfc_entry_list
*entry
;
2408 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2409 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2411 def_sym
= entry
->sym
;
2416 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2418 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2419 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2420 gfc_typename (&def_sym
->ts
));
2424 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2425 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2427 gfc_error ("Explicit interface required for '%s' at %L: %s",
2428 sym
->name
, &sym
->declared_at
, reason
);
2432 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2433 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2434 gfc_errors_to_warnings (1);
2436 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2437 reason
, sizeof(reason
), NULL
, NULL
))
2439 gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
2440 sym
->name
, &sym
->declared_at
, reason
);
2445 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2446 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2447 gfc_errors_to_warnings (1);
2449 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2450 gfc_procedure_use (def_sym
, actual
, where
);
2454 gfc_errors_to_warnings (0);
2456 if (gsym
->type
== GSYM_UNKNOWN
)
2459 gsym
->where
= *where
;
2466 /************* Function resolution *************/
2468 /* Resolve a function call known to be generic.
2469 Section 14.1.2.4.1. */
2472 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2476 if (sym
->attr
.generic
)
2478 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2481 expr
->value
.function
.name
= s
->name
;
2482 expr
->value
.function
.esym
= s
;
2484 if (s
->ts
.type
!= BT_UNKNOWN
)
2486 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2487 expr
->ts
= s
->result
->ts
;
2490 expr
->rank
= s
->as
->rank
;
2491 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2492 expr
->rank
= s
->result
->as
->rank
;
2494 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2499 /* TODO: Need to search for elemental references in generic
2503 if (sym
->attr
.intrinsic
)
2504 return gfc_intrinsic_func_interface (expr
, 0);
2511 resolve_generic_f (gfc_expr
*expr
)
2515 gfc_interface
*intr
= NULL
;
2517 sym
= expr
->symtree
->n
.sym
;
2521 m
= resolve_generic_f0 (expr
, sym
);
2524 else if (m
== MATCH_ERROR
)
2529 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2530 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2533 if (sym
->ns
->parent
== NULL
)
2535 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2539 if (!generic_sym (sym
))
2543 /* Last ditch attempt. See if the reference is to an intrinsic
2544 that possesses a matching interface. 14.1.2.4 */
2545 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2547 gfc_error ("There is no specific function for the generic '%s' "
2548 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2554 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2557 return resolve_structure_cons (expr
, 0);
2560 m
= gfc_intrinsic_func_interface (expr
, 0);
2565 gfc_error ("Generic function '%s' at %L is not consistent with a "
2566 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2573 /* Resolve a function call known to be specific. */
2576 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2580 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2582 if (sym
->attr
.dummy
)
2584 sym
->attr
.proc
= PROC_DUMMY
;
2588 sym
->attr
.proc
= PROC_EXTERNAL
;
2592 if (sym
->attr
.proc
== PROC_MODULE
2593 || sym
->attr
.proc
== PROC_ST_FUNCTION
2594 || sym
->attr
.proc
== PROC_INTERNAL
)
2597 if (sym
->attr
.intrinsic
)
2599 m
= gfc_intrinsic_func_interface (expr
, 1);
2603 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2604 "with an intrinsic", sym
->name
, &expr
->where
);
2612 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2615 expr
->ts
= sym
->result
->ts
;
2618 expr
->value
.function
.name
= sym
->name
;
2619 expr
->value
.function
.esym
= sym
;
2620 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2621 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2622 else if (sym
->as
!= NULL
)
2623 expr
->rank
= sym
->as
->rank
;
2630 resolve_specific_f (gfc_expr
*expr
)
2635 sym
= expr
->symtree
->n
.sym
;
2639 m
= resolve_specific_f0 (sym
, expr
);
2642 if (m
== MATCH_ERROR
)
2645 if (sym
->ns
->parent
== NULL
)
2648 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2654 gfc_error ("Unable to resolve the specific function '%s' at %L",
2655 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2661 /* Resolve a procedure call not known to be generic nor specific. */
2664 resolve_unknown_f (gfc_expr
*expr
)
2669 sym
= expr
->symtree
->n
.sym
;
2671 if (sym
->attr
.dummy
)
2673 sym
->attr
.proc
= PROC_DUMMY
;
2674 expr
->value
.function
.name
= sym
->name
;
2678 /* See if we have an intrinsic function reference. */
2680 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2682 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2687 /* The reference is to an external name. */
2689 sym
->attr
.proc
= PROC_EXTERNAL
;
2690 expr
->value
.function
.name
= sym
->name
;
2691 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2693 if (sym
->as
!= NULL
)
2694 expr
->rank
= sym
->as
->rank
;
2696 /* Type of the expression is either the type of the symbol or the
2697 default type of the symbol. */
2700 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2702 if (sym
->ts
.type
!= BT_UNKNOWN
)
2706 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2708 if (ts
->type
== BT_UNKNOWN
)
2710 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2711 sym
->name
, &expr
->where
);
2722 /* Return true, if the symbol is an external procedure. */
2724 is_external_proc (gfc_symbol
*sym
)
2726 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2727 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2728 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2729 && !sym
->attr
.proc_pointer
2730 && !sym
->attr
.use_assoc
2738 /* Figure out if a function reference is pure or not. Also set the name
2739 of the function for a potential error message. Return nonzero if the
2740 function is PURE, zero if not. */
2742 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2745 pure_function (gfc_expr
*e
, const char **name
)
2751 if (e
->symtree
!= NULL
2752 && e
->symtree
->n
.sym
!= NULL
2753 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2754 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2756 if (e
->value
.function
.esym
)
2758 pure
= gfc_pure (e
->value
.function
.esym
);
2759 *name
= e
->value
.function
.esym
->name
;
2761 else if (e
->value
.function
.isym
)
2763 pure
= e
->value
.function
.isym
->pure
2764 || e
->value
.function
.isym
->elemental
;
2765 *name
= e
->value
.function
.isym
->name
;
2769 /* Implicit functions are not pure. */
2771 *name
= e
->value
.function
.name
;
2779 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2780 int *f ATTRIBUTE_UNUSED
)
2784 /* Don't bother recursing into other statement functions
2785 since they will be checked individually for purity. */
2786 if (e
->expr_type
!= EXPR_FUNCTION
2788 || e
->symtree
->n
.sym
== sym
2789 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2792 return pure_function (e
, &name
) ? false : true;
2797 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2799 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2803 /* Resolve a function call, which means resolving the arguments, then figuring
2804 out which entity the name refers to. */
2807 resolve_function (gfc_expr
*expr
)
2809 gfc_actual_arglist
*arg
;
2814 procedure_type p
= PROC_INTRINSIC
;
2815 bool no_formal_args
;
2819 sym
= expr
->symtree
->n
.sym
;
2821 /* If this is a procedure pointer component, it has already been resolved. */
2822 if (gfc_is_proc_ptr_comp (expr
))
2825 if (sym
&& sym
->attr
.intrinsic
2826 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2829 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2831 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2835 /* If this ia a deferred TBP with an abstract interface (which may
2836 of course be referenced), expr->value.function.esym will be set. */
2837 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2839 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2840 sym
->name
, &expr
->where
);
2844 /* Switch off assumed size checking and do this again for certain kinds
2845 of procedure, once the procedure itself is resolved. */
2846 need_full_assumed_size
++;
2848 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2849 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2851 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2852 inquiry_argument
= true;
2853 no_formal_args
= sym
&& is_external_proc (sym
)
2854 && gfc_sym_get_dummy_args (sym
) == NULL
;
2856 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2859 inquiry_argument
= false;
2863 inquiry_argument
= false;
2865 /* Resume assumed_size checking. */
2866 need_full_assumed_size
--;
2868 /* If the procedure is external, check for usage. */
2869 if (sym
&& is_external_proc (sym
))
2870 resolve_global_procedure (sym
, &expr
->where
,
2871 &expr
->value
.function
.actual
, 0);
2873 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2875 && sym
->ts
.u
.cl
->length
== NULL
2877 && !sym
->ts
.deferred
2878 && expr
->value
.function
.esym
== NULL
2879 && !sym
->attr
.contained
)
2881 /* Internal procedures are taken care of in resolve_contained_fntype. */
2882 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2883 "be used at %L since it is not a dummy argument",
2884 sym
->name
, &expr
->where
);
2888 /* See if function is already resolved. */
2890 if (expr
->value
.function
.name
!= NULL
)
2892 if (expr
->ts
.type
== BT_UNKNOWN
)
2898 /* Apply the rules of section 14.1.2. */
2900 switch (procedure_kind (sym
))
2903 t
= resolve_generic_f (expr
);
2906 case PTYPE_SPECIFIC
:
2907 t
= resolve_specific_f (expr
);
2911 t
= resolve_unknown_f (expr
);
2915 gfc_internal_error ("resolve_function(): bad function type");
2919 /* If the expression is still a function (it might have simplified),
2920 then we check to see if we are calling an elemental function. */
2922 if (expr
->expr_type
!= EXPR_FUNCTION
)
2925 temp
= need_full_assumed_size
;
2926 need_full_assumed_size
= 0;
2928 if (!resolve_elemental_actual (expr
, NULL
))
2931 if (omp_workshare_flag
2932 && expr
->value
.function
.esym
2933 && ! gfc_elemental (expr
->value
.function
.esym
))
2935 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2936 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2941 #define GENERIC_ID expr->value.function.isym->id
2942 else if (expr
->value
.function
.actual
!= NULL
2943 && expr
->value
.function
.isym
!= NULL
2944 && GENERIC_ID
!= GFC_ISYM_LBOUND
2945 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
2946 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
2947 && GENERIC_ID
!= GFC_ISYM_LEN
2948 && GENERIC_ID
!= GFC_ISYM_LOC
2949 && GENERIC_ID
!= GFC_ISYM_C_LOC
2950 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2952 /* Array intrinsics must also have the last upper bound of an
2953 assumed size array argument. UBOUND and SIZE have to be
2954 excluded from the check if the second argument is anything
2957 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2959 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2960 && arg
== expr
->value
.function
.actual
2961 && arg
->next
!= NULL
&& arg
->next
->expr
)
2963 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2966 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2969 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2974 if (arg
->expr
!= NULL
2975 && arg
->expr
->rank
> 0
2976 && resolve_assumed_size_actual (arg
->expr
))
2982 need_full_assumed_size
= temp
;
2985 if (!pure_function (expr
, &name
) && name
)
2989 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2990 "FORALL %s", name
, &expr
->where
,
2991 forall_flag
== 2 ? "mask" : "block");
2994 else if (gfc_do_concurrent_flag
)
2996 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2997 "DO CONCURRENT %s", name
, &expr
->where
,
2998 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3001 else if (gfc_pure (NULL
))
3003 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3004 "procedure within a PURE procedure", name
, &expr
->where
);
3008 gfc_unset_implicit_pure (NULL
);
3011 /* Functions without the RECURSIVE attribution are not allowed to
3012 * call themselves. */
3013 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3016 esym
= expr
->value
.function
.esym
;
3018 if (is_illegal_recursion (esym
, gfc_current_ns
))
3020 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3021 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3022 " function '%s' is not RECURSIVE",
3023 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3025 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3026 " is not RECURSIVE", esym
->name
, &expr
->where
);
3032 /* Character lengths of use associated functions may contains references to
3033 symbols not referenced from the current program unit otherwise. Make sure
3034 those symbols are marked as referenced. */
3036 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3037 && expr
->value
.function
.esym
->attr
.use_assoc
)
3039 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3042 /* Make sure that the expression has a typespec that works. */
3043 if (expr
->ts
.type
== BT_UNKNOWN
)
3045 if (expr
->symtree
->n
.sym
->result
3046 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3047 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3048 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3055 /************* Subroutine resolution *************/
3058 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3064 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3065 sym
->name
, &c
->loc
);
3066 else if (gfc_do_concurrent_flag
)
3067 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3068 "PURE", sym
->name
, &c
->loc
);
3069 else if (gfc_pure (NULL
))
3070 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3073 gfc_unset_implicit_pure (NULL
);
3078 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3082 if (sym
->attr
.generic
)
3084 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3087 c
->resolved_sym
= s
;
3088 pure_subroutine (c
, s
);
3092 /* TODO: Need to search for elemental references in generic interface. */
3095 if (sym
->attr
.intrinsic
)
3096 return gfc_intrinsic_sub_interface (c
, 0);
3103 resolve_generic_s (gfc_code
*c
)
3108 sym
= c
->symtree
->n
.sym
;
3112 m
= resolve_generic_s0 (c
, sym
);
3115 else if (m
== MATCH_ERROR
)
3119 if (sym
->ns
->parent
== NULL
)
3121 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3125 if (!generic_sym (sym
))
3129 /* Last ditch attempt. See if the reference is to an intrinsic
3130 that possesses a matching interface. 14.1.2.4 */
3131 sym
= c
->symtree
->n
.sym
;
3133 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3135 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3136 sym
->name
, &c
->loc
);
3140 m
= gfc_intrinsic_sub_interface (c
, 0);
3144 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3145 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3151 /* Resolve a subroutine call known to be specific. */
3154 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3158 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3160 if (sym
->attr
.dummy
)
3162 sym
->attr
.proc
= PROC_DUMMY
;
3166 sym
->attr
.proc
= PROC_EXTERNAL
;
3170 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3173 if (sym
->attr
.intrinsic
)
3175 m
= gfc_intrinsic_sub_interface (c
, 1);
3179 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3180 "with an intrinsic", sym
->name
, &c
->loc
);
3188 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3190 c
->resolved_sym
= sym
;
3191 pure_subroutine (c
, sym
);
3198 resolve_specific_s (gfc_code
*c
)
3203 sym
= c
->symtree
->n
.sym
;
3207 m
= resolve_specific_s0 (c
, sym
);
3210 if (m
== MATCH_ERROR
)
3213 if (sym
->ns
->parent
== NULL
)
3216 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3222 sym
= c
->symtree
->n
.sym
;
3223 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3224 sym
->name
, &c
->loc
);
3230 /* Resolve a subroutine call not known to be generic nor specific. */
3233 resolve_unknown_s (gfc_code
*c
)
3237 sym
= c
->symtree
->n
.sym
;
3239 if (sym
->attr
.dummy
)
3241 sym
->attr
.proc
= PROC_DUMMY
;
3245 /* See if we have an intrinsic function reference. */
3247 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3249 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3254 /* The reference is to an external name. */
3257 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3259 c
->resolved_sym
= sym
;
3261 pure_subroutine (c
, sym
);
3267 /* Resolve a subroutine call. Although it was tempting to use the same code
3268 for functions, subroutines and functions are stored differently and this
3269 makes things awkward. */
3272 resolve_call (gfc_code
*c
)
3275 procedure_type ptype
= PROC_INTRINSIC
;
3276 gfc_symbol
*csym
, *sym
;
3277 bool no_formal_args
;
3279 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3281 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3283 gfc_error ("'%s' at %L has a type, which is not consistent with "
3284 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3288 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3291 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3292 sym
= st
? st
->n
.sym
: NULL
;
3293 if (sym
&& csym
!= sym
3294 && sym
->ns
== gfc_current_ns
3295 && sym
->attr
.flavor
== FL_PROCEDURE
3296 && sym
->attr
.contained
)
3299 if (csym
->attr
.generic
)
3300 c
->symtree
->n
.sym
= sym
;
3303 csym
= c
->symtree
->n
.sym
;
3307 /* If this ia a deferred TBP, c->expr1 will be set. */
3308 if (!c
->expr1
&& csym
)
3310 if (csym
->attr
.abstract
)
3312 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3313 csym
->name
, &c
->loc
);
3317 /* Subroutines without the RECURSIVE attribution are not allowed to
3319 if (is_illegal_recursion (csym
, gfc_current_ns
))
3321 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3322 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3323 "as subroutine '%s' is not RECURSIVE",
3324 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3326 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3327 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3333 /* Switch off assumed size checking and do this again for certain kinds
3334 of procedure, once the procedure itself is resolved. */
3335 need_full_assumed_size
++;
3338 ptype
= csym
->attr
.proc
;
3340 no_formal_args
= csym
&& is_external_proc (csym
)
3341 && gfc_sym_get_dummy_args (csym
) == NULL
;
3342 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3345 /* Resume assumed_size checking. */
3346 need_full_assumed_size
--;
3348 /* If external, check for usage. */
3349 if (csym
&& is_external_proc (csym
))
3350 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3353 if (c
->resolved_sym
== NULL
)
3355 c
->resolved_isym
= NULL
;
3356 switch (procedure_kind (csym
))
3359 t
= resolve_generic_s (c
);
3362 case PTYPE_SPECIFIC
:
3363 t
= resolve_specific_s (c
);
3367 t
= resolve_unknown_s (c
);
3371 gfc_internal_error ("resolve_subroutine(): bad function type");
3375 /* Some checks of elemental subroutine actual arguments. */
3376 if (!resolve_elemental_actual (NULL
, c
))
3383 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3384 op1->shape and op2->shape are non-NULL return true if their shapes
3385 match. If both op1->shape and op2->shape are non-NULL return false
3386 if their shapes do not match. If either op1->shape or op2->shape is
3387 NULL, return true. */
3390 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3397 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3399 for (i
= 0; i
< op1
->rank
; i
++)
3401 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3403 gfc_error ("Shapes for operands at %L and %L are not conformable",
3404 &op1
->where
, &op2
->where
);
3415 /* Resolve an operator expression node. This can involve replacing the
3416 operation with a user defined function call. */
3419 resolve_operator (gfc_expr
*e
)
3421 gfc_expr
*op1
, *op2
;
3423 bool dual_locus_error
;
3426 /* Resolve all subnodes-- give them types. */
3428 switch (e
->value
.op
.op
)
3431 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3434 /* Fall through... */
3437 case INTRINSIC_UPLUS
:
3438 case INTRINSIC_UMINUS
:
3439 case INTRINSIC_PARENTHESES
:
3440 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3445 /* Typecheck the new node. */
3447 op1
= e
->value
.op
.op1
;
3448 op2
= e
->value
.op
.op2
;
3449 dual_locus_error
= false;
3451 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3452 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3454 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3458 switch (e
->value
.op
.op
)
3460 case INTRINSIC_UPLUS
:
3461 case INTRINSIC_UMINUS
:
3462 if (op1
->ts
.type
== BT_INTEGER
3463 || op1
->ts
.type
== BT_REAL
3464 || op1
->ts
.type
== BT_COMPLEX
)
3470 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3471 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3474 case INTRINSIC_PLUS
:
3475 case INTRINSIC_MINUS
:
3476 case INTRINSIC_TIMES
:
3477 case INTRINSIC_DIVIDE
:
3478 case INTRINSIC_POWER
:
3479 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3481 gfc_type_convert_binary (e
, 1);
3486 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3487 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3488 gfc_typename (&op2
->ts
));
3491 case INTRINSIC_CONCAT
:
3492 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3493 && op1
->ts
.kind
== op2
->ts
.kind
)
3495 e
->ts
.type
= BT_CHARACTER
;
3496 e
->ts
.kind
= op1
->ts
.kind
;
3501 _("Operands of string concatenation operator at %%L are %s/%s"),
3502 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3508 case INTRINSIC_NEQV
:
3509 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3511 e
->ts
.type
= BT_LOGICAL
;
3512 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3513 if (op1
->ts
.kind
< e
->ts
.kind
)
3514 gfc_convert_type (op1
, &e
->ts
, 2);
3515 else if (op2
->ts
.kind
< e
->ts
.kind
)
3516 gfc_convert_type (op2
, &e
->ts
, 2);
3520 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3521 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3522 gfc_typename (&op2
->ts
));
3527 if (op1
->ts
.type
== BT_LOGICAL
)
3529 e
->ts
.type
= BT_LOGICAL
;
3530 e
->ts
.kind
= op1
->ts
.kind
;
3534 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3535 gfc_typename (&op1
->ts
));
3539 case INTRINSIC_GT_OS
:
3541 case INTRINSIC_GE_OS
:
3543 case INTRINSIC_LT_OS
:
3545 case INTRINSIC_LE_OS
:
3546 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3548 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3552 /* Fall through... */
3555 case INTRINSIC_EQ_OS
:
3557 case INTRINSIC_NE_OS
:
3558 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3559 && op1
->ts
.kind
== op2
->ts
.kind
)
3561 e
->ts
.type
= BT_LOGICAL
;
3562 e
->ts
.kind
= gfc_default_logical_kind
;
3566 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3568 gfc_type_convert_binary (e
, 1);
3570 e
->ts
.type
= BT_LOGICAL
;
3571 e
->ts
.kind
= gfc_default_logical_kind
;
3573 if (gfc_option
.warn_compare_reals
)
3575 gfc_intrinsic_op op
= e
->value
.op
.op
;
3577 /* Type conversion has made sure that the types of op1 and op2
3578 agree, so it is only necessary to check the first one. */
3579 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3580 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3581 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3585 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3586 msg
= "Equality comparison for %s at %L";
3588 msg
= "Inequality comparison for %s at %L";
3590 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3597 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3599 _("Logicals at %%L must be compared with %s instead of %s"),
3600 (e
->value
.op
.op
== INTRINSIC_EQ
3601 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3602 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3605 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3606 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3607 gfc_typename (&op2
->ts
));
3611 case INTRINSIC_USER
:
3612 if (e
->value
.op
.uop
->op
== NULL
)
3613 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3614 else if (op2
== NULL
)
3615 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3616 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3619 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3620 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3621 gfc_typename (&op2
->ts
));
3622 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3627 case INTRINSIC_PARENTHESES
:
3629 if (e
->ts
.type
== BT_CHARACTER
)
3630 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3634 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3637 /* Deal with arrayness of an operand through an operator. */
3641 switch (e
->value
.op
.op
)
3643 case INTRINSIC_PLUS
:
3644 case INTRINSIC_MINUS
:
3645 case INTRINSIC_TIMES
:
3646 case INTRINSIC_DIVIDE
:
3647 case INTRINSIC_POWER
:
3648 case INTRINSIC_CONCAT
:
3652 case INTRINSIC_NEQV
:
3654 case INTRINSIC_EQ_OS
:
3656 case INTRINSIC_NE_OS
:
3658 case INTRINSIC_GT_OS
:
3660 case INTRINSIC_GE_OS
:
3662 case INTRINSIC_LT_OS
:
3664 case INTRINSIC_LE_OS
:
3666 if (op1
->rank
== 0 && op2
->rank
== 0)
3669 if (op1
->rank
== 0 && op2
->rank
!= 0)
3671 e
->rank
= op2
->rank
;
3673 if (e
->shape
== NULL
)
3674 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3677 if (op1
->rank
!= 0 && op2
->rank
== 0)
3679 e
->rank
= op1
->rank
;
3681 if (e
->shape
== NULL
)
3682 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3685 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3687 if (op1
->rank
== op2
->rank
)
3689 e
->rank
= op1
->rank
;
3690 if (e
->shape
== NULL
)
3692 t
= compare_shapes (op1
, op2
);
3696 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3701 /* Allow higher level expressions to work. */
3704 /* Try user-defined operators, and otherwise throw an error. */
3705 dual_locus_error
= true;
3707 _("Inconsistent ranks for operator at %%L and %%L"));
3714 case INTRINSIC_PARENTHESES
:
3716 case INTRINSIC_UPLUS
:
3717 case INTRINSIC_UMINUS
:
3718 /* Simply copy arrayness attribute */
3719 e
->rank
= op1
->rank
;
3721 if (e
->shape
== NULL
)
3722 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3730 /* Attempt to simplify the expression. */
3733 t
= gfc_simplify_expr (e
, 0);
3734 /* Some calls do not succeed in simplification and return false
3735 even though there is no error; e.g. variable references to
3736 PARAMETER arrays. */
3737 if (!gfc_is_constant_expr (e
))
3745 match m
= gfc_extend_expr (e
);
3748 if (m
== MATCH_ERROR
)
3752 if (dual_locus_error
)
3753 gfc_error (msg
, &op1
->where
, &op2
->where
);
3755 gfc_error (msg
, &e
->where
);
3761 /************** Array resolution subroutines **************/
3764 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3767 /* Compare two integer expressions. */
3770 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3774 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3775 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3778 /* If either of the types isn't INTEGER, we must have
3779 raised an error earlier. */
3781 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3784 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3794 /* Compare an integer expression with an integer. */
3797 compare_bound_int (gfc_expr
*a
, int b
)
3801 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3804 if (a
->ts
.type
!= BT_INTEGER
)
3805 gfc_internal_error ("compare_bound_int(): Bad expression");
3807 i
= mpz_cmp_si (a
->value
.integer
, b
);
3817 /* Compare an integer expression with a mpz_t. */
3820 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3824 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3827 if (a
->ts
.type
!= BT_INTEGER
)
3828 gfc_internal_error ("compare_bound_int(): Bad expression");
3830 i
= mpz_cmp (a
->value
.integer
, b
);
3840 /* Compute the last value of a sequence given by a triplet.
3841 Return 0 if it wasn't able to compute the last value, or if the
3842 sequence if empty, and 1 otherwise. */
3845 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3846 gfc_expr
*stride
, mpz_t last
)
3850 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3851 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3852 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3855 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3856 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3859 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3861 if (compare_bound (start
, end
) == CMP_GT
)
3863 mpz_set (last
, end
->value
.integer
);
3867 if (compare_bound_int (stride
, 0) == CMP_GT
)
3869 /* Stride is positive */
3870 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3875 /* Stride is negative */
3876 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3881 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3882 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3883 mpz_sub (last
, end
->value
.integer
, rem
);
3890 /* Compare a single dimension of an array reference to the array
3894 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3898 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3900 gcc_assert (ar
->stride
[i
] == NULL
);
3901 /* This implies [*] as [*:] and [*:3] are not possible. */
3902 if (ar
->start
[i
] == NULL
)
3904 gcc_assert (ar
->end
[i
] == NULL
);
3909 /* Given start, end and stride values, calculate the minimum and
3910 maximum referenced indexes. */
3912 switch (ar
->dimen_type
[i
])
3915 case DIMEN_THIS_IMAGE
:
3920 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3923 gfc_warning ("Array reference at %L is out of bounds "
3924 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3925 mpz_get_si (ar
->start
[i
]->value
.integer
),
3926 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3928 gfc_warning ("Array reference at %L is out of bounds "
3929 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3930 mpz_get_si (ar
->start
[i
]->value
.integer
),
3931 mpz_get_si (as
->lower
[i
]->value
.integer
),
3935 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3938 gfc_warning ("Array reference at %L is out of bounds "
3939 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3940 mpz_get_si (ar
->start
[i
]->value
.integer
),
3941 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3943 gfc_warning ("Array reference at %L is out of bounds "
3944 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3945 mpz_get_si (ar
->start
[i
]->value
.integer
),
3946 mpz_get_si (as
->upper
[i
]->value
.integer
),
3955 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3956 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3958 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3960 /* Check for zero stride, which is not allowed. */
3961 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3963 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3967 /* if start == len || (stride > 0 && start < len)
3968 || (stride < 0 && start > len),
3969 then the array section contains at least one element. In this
3970 case, there is an out-of-bounds access if
3971 (start < lower || start > upper). */
3972 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3973 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3974 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3975 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3976 && comp_start_end
== CMP_GT
))
3978 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3980 gfc_warning ("Lower array reference at %L is out of bounds "
3981 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3982 mpz_get_si (AR_START
->value
.integer
),
3983 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3986 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3988 gfc_warning ("Lower array reference at %L is out of bounds "
3989 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3990 mpz_get_si (AR_START
->value
.integer
),
3991 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3996 /* If we can compute the highest index of the array section,
3997 then it also has to be between lower and upper. */
3998 mpz_init (last_value
);
3999 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4002 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4004 gfc_warning ("Upper array reference at %L is out of bounds "
4005 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4006 mpz_get_si (last_value
),
4007 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4008 mpz_clear (last_value
);
4011 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4013 gfc_warning ("Upper array reference at %L is out of bounds "
4014 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4015 mpz_get_si (last_value
),
4016 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4017 mpz_clear (last_value
);
4021 mpz_clear (last_value
);
4029 gfc_internal_error ("check_dimension(): Bad array reference");
4036 /* Compare an array reference with an array specification. */
4039 compare_spec_to_ref (gfc_array_ref
*ar
)
4046 /* TODO: Full array sections are only allowed as actual parameters. */
4047 if (as
->type
== AS_ASSUMED_SIZE
4048 && (/*ar->type == AR_FULL
4049 ||*/ (ar
->type
== AR_SECTION
4050 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4052 gfc_error ("Rightmost upper bound of assumed size array section "
4053 "not specified at %L", &ar
->where
);
4057 if (ar
->type
== AR_FULL
)
4060 if (as
->rank
!= ar
->dimen
)
4062 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4063 &ar
->where
, ar
->dimen
, as
->rank
);
4067 /* ar->codimen == 0 is a local array. */
4068 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4070 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4071 &ar
->where
, ar
->codimen
, as
->corank
);
4075 for (i
= 0; i
< as
->rank
; i
++)
4076 if (!check_dimension (i
, ar
, as
))
4079 /* Local access has no coarray spec. */
4080 if (ar
->codimen
!= 0)
4081 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4083 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4084 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4086 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4087 i
+ 1 - as
->rank
, &ar
->where
);
4090 if (!check_dimension (i
, ar
, as
))
4098 /* Resolve one part of an array index. */
4101 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4102 int force_index_integer_kind
)
4109 if (!gfc_resolve_expr (index
))
4112 if (check_scalar
&& index
->rank
!= 0)
4114 gfc_error ("Array index at %L must be scalar", &index
->where
);
4118 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4120 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4121 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4125 if (index
->ts
.type
== BT_REAL
)
4126 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4130 if ((index
->ts
.kind
!= gfc_index_integer_kind
4131 && force_index_integer_kind
)
4132 || index
->ts
.type
!= BT_INTEGER
)
4135 ts
.type
= BT_INTEGER
;
4136 ts
.kind
= gfc_index_integer_kind
;
4138 gfc_convert_type_warn (index
, &ts
, 2, 0);
4144 /* Resolve one part of an array index. */
4147 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4149 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4152 /* Resolve a dim argument to an intrinsic function. */
4155 gfc_resolve_dim_arg (gfc_expr
*dim
)
4160 if (!gfc_resolve_expr (dim
))
4165 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4170 if (dim
->ts
.type
!= BT_INTEGER
)
4172 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4176 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4181 ts
.type
= BT_INTEGER
;
4182 ts
.kind
= gfc_index_integer_kind
;
4184 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4190 /* Given an expression that contains array references, update those array
4191 references to point to the right array specifications. While this is
4192 filled in during matching, this information is difficult to save and load
4193 in a module, so we take care of it here.
4195 The idea here is that the original array reference comes from the
4196 base symbol. We traverse the list of reference structures, setting
4197 the stored reference to references. Component references can
4198 provide an additional array specification. */
4201 find_array_spec (gfc_expr
*e
)
4207 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4208 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4210 as
= e
->symtree
->n
.sym
->as
;
4212 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4217 gfc_internal_error ("find_array_spec(): Missing spec");
4224 c
= ref
->u
.c
.component
;
4225 if (c
->attr
.dimension
)
4228 gfc_internal_error ("find_array_spec(): unused as(1)");
4239 gfc_internal_error ("find_array_spec(): unused as(2)");
4243 /* Resolve an array reference. */
4246 resolve_array_ref (gfc_array_ref
*ar
)
4248 int i
, check_scalar
;
4251 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4253 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4255 /* Do not force gfc_index_integer_kind for the start. We can
4256 do fine with any integer kind. This avoids temporary arrays
4257 created for indexing with a vector. */
4258 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4260 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4262 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4267 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4271 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4275 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4276 if (e
->expr_type
== EXPR_VARIABLE
4277 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4278 ar
->start
[i
] = gfc_get_parentheses (e
);
4282 gfc_error ("Array index at %L is an array of rank %d",
4283 &ar
->c_where
[i
], e
->rank
);
4287 /* Fill in the upper bound, which may be lower than the
4288 specified one for something like a(2:10:5), which is
4289 identical to a(2:7:5). Only relevant for strides not equal
4290 to one. Don't try a division by zero. */
4291 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4292 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4293 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4294 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4298 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4300 if (ar
->end
[i
] == NULL
)
4303 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4305 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4307 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4308 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4310 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4321 if (ar
->type
== AR_FULL
)
4323 if (ar
->as
->rank
== 0)
4324 ar
->type
= AR_ELEMENT
;
4326 /* Make sure array is the same as array(:,:), this way
4327 we don't need to special case all the time. */
4328 ar
->dimen
= ar
->as
->rank
;
4329 for (i
= 0; i
< ar
->dimen
; i
++)
4331 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4333 gcc_assert (ar
->start
[i
] == NULL
);
4334 gcc_assert (ar
->end
[i
] == NULL
);
4335 gcc_assert (ar
->stride
[i
] == NULL
);
4339 /* If the reference type is unknown, figure out what kind it is. */
4341 if (ar
->type
== AR_UNKNOWN
)
4343 ar
->type
= AR_ELEMENT
;
4344 for (i
= 0; i
< ar
->dimen
; i
++)
4345 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4346 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4348 ar
->type
= AR_SECTION
;
4353 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4356 if (ar
->as
->corank
&& ar
->codimen
== 0)
4359 ar
->codimen
= ar
->as
->corank
;
4360 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4361 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4369 resolve_substring (gfc_ref
*ref
)
4371 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4373 if (ref
->u
.ss
.start
!= NULL
)
4375 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4378 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4380 gfc_error ("Substring start index at %L must be of type INTEGER",
4381 &ref
->u
.ss
.start
->where
);
4385 if (ref
->u
.ss
.start
->rank
!= 0)
4387 gfc_error ("Substring start index at %L must be scalar",
4388 &ref
->u
.ss
.start
->where
);
4392 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4393 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4394 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4396 gfc_error ("Substring start index at %L is less than one",
4397 &ref
->u
.ss
.start
->where
);
4402 if (ref
->u
.ss
.end
!= NULL
)
4404 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4407 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4409 gfc_error ("Substring end index at %L must be of type INTEGER",
4410 &ref
->u
.ss
.end
->where
);
4414 if (ref
->u
.ss
.end
->rank
!= 0)
4416 gfc_error ("Substring end index at %L must be scalar",
4417 &ref
->u
.ss
.end
->where
);
4421 if (ref
->u
.ss
.length
!= NULL
4422 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4423 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4424 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4426 gfc_error ("Substring end index at %L exceeds the string length",
4427 &ref
->u
.ss
.start
->where
);
4431 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4432 gfc_integer_kinds
[k
].huge
) == CMP_GT
4433 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4434 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4436 gfc_error ("Substring end index at %L is too large",
4437 &ref
->u
.ss
.end
->where
);
4446 /* This function supplies missing substring charlens. */
4449 gfc_resolve_substring_charlen (gfc_expr
*e
)
4452 gfc_expr
*start
, *end
;
4454 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4455 if (char_ref
->type
== REF_SUBSTRING
)
4461 gcc_assert (char_ref
->next
== NULL
);
4465 if (e
->ts
.u
.cl
->length
)
4466 gfc_free_expr (e
->ts
.u
.cl
->length
);
4467 else if (e
->expr_type
== EXPR_VARIABLE
4468 && e
->symtree
->n
.sym
->attr
.dummy
)
4472 e
->ts
.type
= BT_CHARACTER
;
4473 e
->ts
.kind
= gfc_default_character_kind
;
4476 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4478 if (char_ref
->u
.ss
.start
)
4479 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4481 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4483 if (char_ref
->u
.ss
.end
)
4484 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4485 else if (e
->expr_type
== EXPR_VARIABLE
)
4486 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4492 gfc_free_expr (start
);
4493 gfc_free_expr (end
);
4497 /* Length = (end - start +1). */
4498 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4499 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4500 gfc_get_int_expr (gfc_default_integer_kind
,
4503 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4504 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4506 /* Make sure that the length is simplified. */
4507 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4508 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4512 /* Resolve subtype references. */
4515 resolve_ref (gfc_expr
*expr
)
4517 int current_part_dimension
, n_components
, seen_part_dimension
;
4520 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4521 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4523 find_array_spec (expr
);
4527 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4531 if (!resolve_array_ref (&ref
->u
.ar
))
4539 if (!resolve_substring (ref
))
4544 /* Check constraints on part references. */
4546 current_part_dimension
= 0;
4547 seen_part_dimension
= 0;
4550 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4555 switch (ref
->u
.ar
.type
)
4558 /* Coarray scalar. */
4559 if (ref
->u
.ar
.as
->rank
== 0)
4561 current_part_dimension
= 0;
4566 current_part_dimension
= 1;
4570 current_part_dimension
= 0;
4574 gfc_internal_error ("resolve_ref(): Bad array reference");
4580 if (current_part_dimension
|| seen_part_dimension
)
4583 if (ref
->u
.c
.component
->attr
.pointer
4584 || ref
->u
.c
.component
->attr
.proc_pointer
4585 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4586 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4588 gfc_error ("Component to the right of a part reference "
4589 "with nonzero rank must not have the POINTER "
4590 "attribute at %L", &expr
->where
);
4593 else if (ref
->u
.c
.component
->attr
.allocatable
4594 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4595 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4598 gfc_error ("Component to the right of a part reference "
4599 "with nonzero rank must not have the ALLOCATABLE "
4600 "attribute at %L", &expr
->where
);
4612 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4613 || ref
->next
== NULL
)
4614 && current_part_dimension
4615 && seen_part_dimension
)
4617 gfc_error ("Two or more part references with nonzero rank must "
4618 "not be specified at %L", &expr
->where
);
4622 if (ref
->type
== REF_COMPONENT
)
4624 if (current_part_dimension
)
4625 seen_part_dimension
= 1;
4627 /* reset to make sure */
4628 current_part_dimension
= 0;
4636 /* Given an expression, determine its shape. This is easier than it sounds.
4637 Leaves the shape array NULL if it is not possible to determine the shape. */
4640 expression_shape (gfc_expr
*e
)
4642 mpz_t array
[GFC_MAX_DIMENSIONS
];
4645 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4648 for (i
= 0; i
< e
->rank
; i
++)
4649 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4652 e
->shape
= gfc_get_shape (e
->rank
);
4654 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4659 for (i
--; i
>= 0; i
--)
4660 mpz_clear (array
[i
]);
4664 /* Given a variable expression node, compute the rank of the expression by
4665 examining the base symbol and any reference structures it may have. */
4668 expression_rank (gfc_expr
*e
)
4673 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4674 could lead to serious confusion... */
4675 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4679 if (e
->expr_type
== EXPR_ARRAY
)
4681 /* Constructors can have a rank different from one via RESHAPE(). */
4683 if (e
->symtree
== NULL
)
4689 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4690 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4696 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4698 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4699 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4700 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4702 if (ref
->type
!= REF_ARRAY
)
4705 if (ref
->u
.ar
.type
== AR_FULL
)
4707 rank
= ref
->u
.ar
.as
->rank
;
4711 if (ref
->u
.ar
.type
== AR_SECTION
)
4713 /* Figure out the rank of the section. */
4715 gfc_internal_error ("expression_rank(): Two array specs");
4717 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4718 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4719 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4729 expression_shape (e
);
4733 /* Resolve a variable expression. */
4736 resolve_variable (gfc_expr
*e
)
4743 if (e
->symtree
== NULL
)
4745 sym
= e
->symtree
->n
.sym
;
4747 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4748 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4749 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4751 if (!actual_arg
|| inquiry_argument
)
4753 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4754 "be used as actual argument", sym
->name
, &e
->where
);
4758 /* TS 29113, 407b. */
4759 else if (e
->ts
.type
== BT_ASSUMED
)
4763 gfc_error ("Assumed-type variable %s at %L may only be used "
4764 "as actual argument", sym
->name
, &e
->where
);
4767 else if (inquiry_argument
&& !first_actual_arg
)
4769 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4770 for all inquiry functions in resolve_function; the reason is
4771 that the function-name resolution happens too late in that
4773 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4774 "an inquiry function shall be the first argument",
4775 sym
->name
, &e
->where
);
4779 /* TS 29113, C535b. */
4780 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4781 && CLASS_DATA (sym
)->as
4782 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4783 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4784 && sym
->as
->type
== AS_ASSUMED_RANK
))
4788 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4789 "actual argument", sym
->name
, &e
->where
);
4792 else if (inquiry_argument
&& !first_actual_arg
)
4794 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4795 for all inquiry functions in resolve_function; the reason is
4796 that the function-name resolution happens too late in that
4798 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4799 "to an inquiry function shall be the first argument",
4800 sym
->name
, &e
->where
);
4805 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4806 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4807 && e
->ref
->next
== NULL
))
4809 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4810 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4813 /* TS 29113, 407b. */
4814 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4815 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4816 && e
->ref
->next
== NULL
))
4818 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4819 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4823 /* TS 29113, C535b. */
4824 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4825 && CLASS_DATA (sym
)->as
4826 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4827 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4828 && sym
->as
->type
== AS_ASSUMED_RANK
))
4830 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4831 && e
->ref
->next
== NULL
))
4833 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4834 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4839 /* If this is an associate-name, it may be parsed with an array reference
4840 in error even though the target is scalar. Fail directly in this case.
4841 TODO Understand why class scalar expressions must be excluded. */
4842 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4844 if (sym
->ts
.type
== BT_CLASS
)
4845 gfc_fix_class_refs (e
);
4846 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4850 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4851 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4853 /* On the other hand, the parser may not have known this is an array;
4854 in this case, we have to add a FULL reference. */
4855 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4857 e
->ref
= gfc_get_ref ();
4858 e
->ref
->type
= REF_ARRAY
;
4859 e
->ref
->u
.ar
.type
= AR_FULL
;
4860 e
->ref
->u
.ar
.dimen
= 0;
4863 if (e
->ref
&& !resolve_ref (e
))
4866 if (sym
->attr
.flavor
== FL_PROCEDURE
4867 && (!sym
->attr
.function
4868 || (sym
->attr
.function
&& sym
->result
4869 && sym
->result
->attr
.proc_pointer
4870 && !sym
->result
->attr
.function
)))
4872 e
->ts
.type
= BT_PROCEDURE
;
4873 goto resolve_procedure
;
4876 if (sym
->ts
.type
!= BT_UNKNOWN
)
4877 gfc_variable_attr (e
, &e
->ts
);
4880 /* Must be a simple variable reference. */
4881 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4886 if (check_assumed_size_reference (sym
, e
))
4889 /* Deal with forward references to entries during resolve_code, to
4890 satisfy, at least partially, 12.5.2.5. */
4891 if (gfc_current_ns
->entries
4892 && current_entry_id
== sym
->entry_id
4895 && cs_base
->current
->op
!= EXEC_ENTRY
)
4897 gfc_entry_list
*entry
;
4898 gfc_formal_arglist
*formal
;
4900 bool seen
, saved_specification_expr
;
4902 /* If the symbol is a dummy... */
4903 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4905 entry
= gfc_current_ns
->entries
;
4908 /* ...test if the symbol is a parameter of previous entries. */
4909 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4910 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4912 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4919 /* If it has not been seen as a dummy, this is an error. */
4922 if (specification_expr
)
4923 gfc_error ("Variable '%s', used in a specification expression"
4924 ", is referenced at %L before the ENTRY statement "
4925 "in which it is a parameter",
4926 sym
->name
, &cs_base
->current
->loc
);
4928 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4929 "statement in which it is a parameter",
4930 sym
->name
, &cs_base
->current
->loc
);
4935 /* Now do the same check on the specification expressions. */
4936 saved_specification_expr
= specification_expr
;
4937 specification_expr
= true;
4938 if (sym
->ts
.type
== BT_CHARACTER
4939 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4943 for (n
= 0; n
< sym
->as
->rank
; n
++)
4945 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4947 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4950 specification_expr
= saved_specification_expr
;
4953 /* Update the symbol's entry level. */
4954 sym
->entry_id
= current_entry_id
+ 1;
4957 /* If a symbol has been host_associated mark it. This is used latter,
4958 to identify if aliasing is possible via host association. */
4959 if (sym
->attr
.flavor
== FL_VARIABLE
4960 && gfc_current_ns
->parent
4961 && (gfc_current_ns
->parent
== sym
->ns
4962 || (gfc_current_ns
->parent
->parent
4963 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
4964 sym
->attr
.host_assoc
= 1;
4967 if (t
&& !resolve_procedure_expression (e
))
4970 /* F2008, C617 and C1229. */
4971 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
4972 && gfc_is_coindexed (e
))
4974 gfc_ref
*ref
, *ref2
= NULL
;
4976 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4978 if (ref
->type
== REF_COMPONENT
)
4980 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4984 for ( ; ref
; ref
= ref
->next
)
4985 if (ref
->type
== REF_COMPONENT
)
4988 /* Expression itself is not coindexed object. */
4989 if (ref
&& e
->ts
.type
== BT_CLASS
)
4991 gfc_error ("Polymorphic subobject of coindexed object at %L",
4996 /* Expression itself is coindexed object. */
5000 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5001 for ( ; c
; c
= c
->next
)
5002 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5004 gfc_error ("Coindexed object with polymorphic allocatable "
5005 "subcomponent at %L", &e
->where
);
5016 /* Checks to see that the correct symbol has been host associated.
5017 The only situation where this arises is that in which a twice
5018 contained function is parsed after the host association is made.
5019 Therefore, on detecting this, change the symbol in the expression
5020 and convert the array reference into an actual arglist if the old
5021 symbol is a variable. */
5023 check_host_association (gfc_expr
*e
)
5025 gfc_symbol
*sym
, *old_sym
;
5029 gfc_actual_arglist
*arg
, *tail
= NULL
;
5030 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5032 /* If the expression is the result of substitution in
5033 interface.c(gfc_extend_expr) because there is no way in
5034 which the host association can be wrong. */
5035 if (e
->symtree
== NULL
5036 || e
->symtree
->n
.sym
== NULL
5037 || e
->user_operator
)
5040 old_sym
= e
->symtree
->n
.sym
;
5042 if (gfc_current_ns
->parent
5043 && old_sym
->ns
!= gfc_current_ns
)
5045 /* Use the 'USE' name so that renamed module symbols are
5046 correctly handled. */
5047 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5049 if (sym
&& old_sym
!= sym
5050 && sym
->ts
.type
== old_sym
->ts
.type
5051 && sym
->attr
.flavor
== FL_PROCEDURE
5052 && sym
->attr
.contained
)
5054 /* Clear the shape, since it might not be valid. */
5055 gfc_free_shape (&e
->shape
, e
->rank
);
5057 /* Give the expression the right symtree! */
5058 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5059 gcc_assert (st
!= NULL
);
5061 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5062 || e
->expr_type
== EXPR_FUNCTION
)
5064 /* Original was function so point to the new symbol, since
5065 the actual argument list is already attached to the
5067 e
->value
.function
.esym
= NULL
;
5072 /* Original was variable so convert array references into
5073 an actual arglist. This does not need any checking now
5074 since resolve_function will take care of it. */
5075 e
->value
.function
.actual
= NULL
;
5076 e
->expr_type
= EXPR_FUNCTION
;
5079 /* Ambiguity will not arise if the array reference is not
5080 the last reference. */
5081 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5082 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5085 gcc_assert (ref
->type
== REF_ARRAY
);
5087 /* Grab the start expressions from the array ref and
5088 copy them into actual arguments. */
5089 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5091 arg
= gfc_get_actual_arglist ();
5092 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5093 if (e
->value
.function
.actual
== NULL
)
5094 tail
= e
->value
.function
.actual
= arg
;
5102 /* Dump the reference list and set the rank. */
5103 gfc_free_ref_list (e
->ref
);
5105 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5108 gfc_resolve_expr (e
);
5112 /* This might have changed! */
5113 return e
->expr_type
== EXPR_FUNCTION
;
5118 gfc_resolve_character_operator (gfc_expr
*e
)
5120 gfc_expr
*op1
= e
->value
.op
.op1
;
5121 gfc_expr
*op2
= e
->value
.op
.op2
;
5122 gfc_expr
*e1
= NULL
;
5123 gfc_expr
*e2
= NULL
;
5125 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5127 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5128 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5129 else if (op1
->expr_type
== EXPR_CONSTANT
)
5130 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5131 op1
->value
.character
.length
);
5133 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5134 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5135 else if (op2
->expr_type
== EXPR_CONSTANT
)
5136 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5137 op2
->value
.character
.length
);
5139 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5149 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5150 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5151 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5152 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5153 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5159 /* Ensure that an character expression has a charlen and, if possible, a
5160 length expression. */
5163 fixup_charlen (gfc_expr
*e
)
5165 /* The cases fall through so that changes in expression type and the need
5166 for multiple fixes are picked up. In all circumstances, a charlen should
5167 be available for the middle end to hang a backend_decl on. */
5168 switch (e
->expr_type
)
5171 gfc_resolve_character_operator (e
);
5174 if (e
->expr_type
== EXPR_ARRAY
)
5175 gfc_resolve_character_array_constructor (e
);
5177 case EXPR_SUBSTRING
:
5178 if (!e
->ts
.u
.cl
&& e
->ref
)
5179 gfc_resolve_substring_charlen (e
);
5183 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5190 /* Update an actual argument to include the passed-object for type-bound
5191 procedures at the right position. */
5193 static gfc_actual_arglist
*
5194 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5197 gcc_assert (argpos
> 0);
5201 gfc_actual_arglist
* result
;
5203 result
= gfc_get_actual_arglist ();
5207 result
->name
= name
;
5213 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5215 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5220 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5223 extract_compcall_passed_object (gfc_expr
* e
)
5227 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5229 if (e
->value
.compcall
.base_object
)
5230 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5233 po
= gfc_get_expr ();
5234 po
->expr_type
= EXPR_VARIABLE
;
5235 po
->symtree
= e
->symtree
;
5236 po
->ref
= gfc_copy_ref (e
->ref
);
5237 po
->where
= e
->where
;
5240 if (!gfc_resolve_expr (po
))
5247 /* Update the arglist of an EXPR_COMPCALL expression to include the
5251 update_compcall_arglist (gfc_expr
* e
)
5254 gfc_typebound_proc
* tbp
;
5256 tbp
= e
->value
.compcall
.tbp
;
5261 po
= extract_compcall_passed_object (e
);
5265 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5271 gcc_assert (tbp
->pass_arg_num
> 0);
5272 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5280 /* Extract the passed object from a PPC call (a copy of it). */
5283 extract_ppc_passed_object (gfc_expr
*e
)
5288 po
= gfc_get_expr ();
5289 po
->expr_type
= EXPR_VARIABLE
;
5290 po
->symtree
= e
->symtree
;
5291 po
->ref
= gfc_copy_ref (e
->ref
);
5292 po
->where
= e
->where
;
5294 /* Remove PPC reference. */
5296 while ((*ref
)->next
)
5297 ref
= &(*ref
)->next
;
5298 gfc_free_ref_list (*ref
);
5301 if (!gfc_resolve_expr (po
))
5308 /* Update the actual arglist of a procedure pointer component to include the
5312 update_ppc_arglist (gfc_expr
* e
)
5316 gfc_typebound_proc
* tb
;
5318 ppc
= gfc_get_proc_ptr_comp (e
);
5326 else if (tb
->nopass
)
5329 po
= extract_ppc_passed_object (e
);
5336 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5341 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5343 gfc_error ("Base object for procedure-pointer component call at %L is of"
5344 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5348 gcc_assert (tb
->pass_arg_num
> 0);
5349 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5357 /* Check that the object a TBP is called on is valid, i.e. it must not be
5358 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5361 check_typebound_baseobject (gfc_expr
* e
)
5364 bool return_value
= false;
5366 base
= extract_compcall_passed_object (e
);
5370 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5372 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5376 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5378 gfc_error ("Base object for type-bound procedure call at %L is of"
5379 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5383 /* F08:C1230. If the procedure called is NOPASS,
5384 the base object must be scalar. */
5385 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5387 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5388 " be scalar", &e
->where
);
5392 return_value
= true;
5395 gfc_free_expr (base
);
5396 return return_value
;
5400 /* Resolve a call to a type-bound procedure, either function or subroutine,
5401 statically from the data in an EXPR_COMPCALL expression. The adapted
5402 arglist and the target-procedure symtree are returned. */
5405 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5406 gfc_actual_arglist
** actual
)
5408 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5409 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5411 /* Update the actual arglist for PASS. */
5412 if (!update_compcall_arglist (e
))
5415 *actual
= e
->value
.compcall
.actual
;
5416 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5418 gfc_free_ref_list (e
->ref
);
5420 e
->value
.compcall
.actual
= NULL
;
5422 /* If we find a deferred typebound procedure, check for derived types
5423 that an overriding typebound procedure has not been missed. */
5424 if (e
->value
.compcall
.name
5425 && !e
->value
.compcall
.tbp
->non_overridable
5426 && e
->value
.compcall
.base_object
5427 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5430 gfc_symbol
*derived
;
5432 /* Use the derived type of the base_object. */
5433 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5436 /* If necessary, go through the inheritance chain. */
5437 while (!st
&& derived
)
5439 /* Look for the typebound procedure 'name'. */
5440 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5441 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5442 e
->value
.compcall
.name
);
5444 derived
= gfc_get_derived_super_type (derived
);
5447 /* Now find the specific name in the derived type namespace. */
5448 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5449 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5450 derived
->ns
, 1, &st
);
5458 /* Get the ultimate declared type from an expression. In addition,
5459 return the last class/derived type reference and the copy of the
5460 reference list. If check_types is set true, derived types are
5461 identified as well as class references. */
5463 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5464 gfc_expr
*e
, bool check_types
)
5466 gfc_symbol
*declared
;
5473 *new_ref
= gfc_copy_ref (e
->ref
);
5475 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5477 if (ref
->type
!= REF_COMPONENT
)
5480 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5481 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5482 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5484 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5490 if (declared
== NULL
)
5491 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5497 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5498 which of the specific bindings (if any) matches the arglist and transform
5499 the expression into a call of that binding. */
5502 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5504 gfc_typebound_proc
* genproc
;
5505 const char* genname
;
5507 gfc_symbol
*derived
;
5509 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5510 genname
= e
->value
.compcall
.name
;
5511 genproc
= e
->value
.compcall
.tbp
;
5513 if (!genproc
->is_generic
)
5516 /* Try the bindings on this type and in the inheritance hierarchy. */
5517 for (; genproc
; genproc
= genproc
->overridden
)
5521 gcc_assert (genproc
->is_generic
);
5522 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5525 gfc_actual_arglist
* args
;
5528 gcc_assert (g
->specific
);
5530 if (g
->specific
->error
)
5533 target
= g
->specific
->u
.specific
->n
.sym
;
5535 /* Get the right arglist by handling PASS/NOPASS. */
5536 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5537 if (!g
->specific
->nopass
)
5540 po
= extract_compcall_passed_object (e
);
5543 gfc_free_actual_arglist (args
);
5547 gcc_assert (g
->specific
->pass_arg_num
> 0);
5548 gcc_assert (!g
->specific
->error
);
5549 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5550 g
->specific
->pass_arg
);
5552 resolve_actual_arglist (args
, target
->attr
.proc
,
5553 is_external_proc (target
)
5554 && gfc_sym_get_dummy_args (target
) == NULL
);
5556 /* Check if this arglist matches the formal. */
5557 matches
= gfc_arglist_matches_symbol (&args
, target
);
5559 /* Clean up and break out of the loop if we've found it. */
5560 gfc_free_actual_arglist (args
);
5563 e
->value
.compcall
.tbp
= g
->specific
;
5564 genname
= g
->specific_st
->name
;
5565 /* Pass along the name for CLASS methods, where the vtab
5566 procedure pointer component has to be referenced. */
5574 /* Nothing matching found! */
5575 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5576 " '%s' at %L", genname
, &e
->where
);
5580 /* Make sure that we have the right specific instance for the name. */
5581 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5583 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5585 e
->value
.compcall
.tbp
= st
->n
.tb
;
5591 /* Resolve a call to a type-bound subroutine. */
5594 resolve_typebound_call (gfc_code
* c
, const char **name
)
5596 gfc_actual_arglist
* newactual
;
5597 gfc_symtree
* target
;
5599 /* Check that's really a SUBROUTINE. */
5600 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5602 gfc_error ("'%s' at %L should be a SUBROUTINE",
5603 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5607 if (!check_typebound_baseobject (c
->expr1
))
5610 /* Pass along the name for CLASS methods, where the vtab
5611 procedure pointer component has to be referenced. */
5613 *name
= c
->expr1
->value
.compcall
.name
;
5615 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5618 /* Transform into an ordinary EXEC_CALL for now. */
5620 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5623 c
->ext
.actual
= newactual
;
5624 c
->symtree
= target
;
5625 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5627 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5629 gfc_free_expr (c
->expr1
);
5630 c
->expr1
= gfc_get_expr ();
5631 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5632 c
->expr1
->symtree
= target
;
5633 c
->expr1
->where
= c
->loc
;
5635 return resolve_call (c
);
5639 /* Resolve a component-call expression. */
5641 resolve_compcall (gfc_expr
* e
, const char **name
)
5643 gfc_actual_arglist
* newactual
;
5644 gfc_symtree
* target
;
5646 /* Check that's really a FUNCTION. */
5647 if (!e
->value
.compcall
.tbp
->function
)
5649 gfc_error ("'%s' at %L should be a FUNCTION",
5650 e
->value
.compcall
.name
, &e
->where
);
5654 /* These must not be assign-calls! */
5655 gcc_assert (!e
->value
.compcall
.assign
);
5657 if (!check_typebound_baseobject (e
))
5660 /* Pass along the name for CLASS methods, where the vtab
5661 procedure pointer component has to be referenced. */
5663 *name
= e
->value
.compcall
.name
;
5665 if (!resolve_typebound_generic_call (e
, name
))
5667 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5669 /* Take the rank from the function's symbol. */
5670 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5671 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5673 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5674 arglist to the TBP's binding target. */
5676 if (!resolve_typebound_static (e
, &target
, &newactual
))
5679 e
->value
.function
.actual
= newactual
;
5680 e
->value
.function
.name
= NULL
;
5681 e
->value
.function
.esym
= target
->n
.sym
;
5682 e
->value
.function
.isym
= NULL
;
5683 e
->symtree
= target
;
5684 e
->ts
= target
->n
.sym
->ts
;
5685 e
->expr_type
= EXPR_FUNCTION
;
5687 /* Resolution is not necessary if this is a class subroutine; this
5688 function only has to identify the specific proc. Resolution of
5689 the call will be done next in resolve_typebound_call. */
5690 return gfc_resolve_expr (e
);
5694 static bool resolve_fl_derived (gfc_symbol
*sym
);
5697 /* Resolve a typebound function, or 'method'. First separate all
5698 the non-CLASS references by calling resolve_compcall directly. */
5701 resolve_typebound_function (gfc_expr
* e
)
5703 gfc_symbol
*declared
;
5715 /* Deal with typebound operators for CLASS objects. */
5716 expr
= e
->value
.compcall
.base_object
;
5717 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5718 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5720 /* If the base_object is not a variable, the corresponding actual
5721 argument expression must be stored in e->base_expression so
5722 that the corresponding tree temporary can be used as the base
5723 object in gfc_conv_procedure_call. */
5724 if (expr
->expr_type
!= EXPR_VARIABLE
)
5726 gfc_actual_arglist
*args
;
5728 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5730 if (expr
== args
->expr
)
5735 /* Since the typebound operators are generic, we have to ensure
5736 that any delays in resolution are corrected and that the vtab
5739 declared
= ts
.u
.derived
;
5740 c
= gfc_find_component (declared
, "_vptr", true, true);
5741 if (c
->ts
.u
.derived
== NULL
)
5742 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5744 if (!resolve_compcall (e
, &name
))
5747 /* Use the generic name if it is there. */
5748 name
= name
? name
: e
->value
.function
.esym
->name
;
5749 e
->symtree
= expr
->symtree
;
5750 e
->ref
= gfc_copy_ref (expr
->ref
);
5751 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5753 /* Trim away the extraneous references that emerge from nested
5754 use of interface.c (extend_expr). */
5755 if (class_ref
&& class_ref
->next
)
5757 gfc_free_ref_list (class_ref
->next
);
5758 class_ref
->next
= NULL
;
5760 else if (e
->ref
&& !class_ref
)
5762 gfc_free_ref_list (e
->ref
);
5766 gfc_add_vptr_component (e
);
5767 gfc_add_component_ref (e
, name
);
5768 e
->value
.function
.esym
= NULL
;
5769 if (expr
->expr_type
!= EXPR_VARIABLE
)
5770 e
->base_expr
= expr
;
5775 return resolve_compcall (e
, NULL
);
5777 if (!resolve_ref (e
))
5780 /* Get the CLASS declared type. */
5781 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5783 if (!resolve_fl_derived (declared
))
5786 /* Weed out cases of the ultimate component being a derived type. */
5787 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5788 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5790 gfc_free_ref_list (new_ref
);
5791 return resolve_compcall (e
, NULL
);
5794 c
= gfc_find_component (declared
, "_data", true, true);
5795 declared
= c
->ts
.u
.derived
;
5797 /* Treat the call as if it is a typebound procedure, in order to roll
5798 out the correct name for the specific function. */
5799 if (!resolve_compcall (e
, &name
))
5801 gfc_free_ref_list (new_ref
);
5808 /* Convert the expression to a procedure pointer component call. */
5809 e
->value
.function
.esym
= NULL
;
5815 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5816 gfc_add_vptr_component (e
);
5817 gfc_add_component_ref (e
, name
);
5819 /* Recover the typespec for the expression. This is really only
5820 necessary for generic procedures, where the additional call
5821 to gfc_add_component_ref seems to throw the collection of the
5822 correct typespec. */
5826 gfc_free_ref_list (new_ref
);
5831 /* Resolve a typebound subroutine, or 'method'. First separate all
5832 the non-CLASS references by calling resolve_typebound_call
5836 resolve_typebound_subroutine (gfc_code
*code
)
5838 gfc_symbol
*declared
;
5848 st
= code
->expr1
->symtree
;
5850 /* Deal with typebound operators for CLASS objects. */
5851 expr
= code
->expr1
->value
.compcall
.base_object
;
5852 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5853 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5855 /* If the base_object is not a variable, the corresponding actual
5856 argument expression must be stored in e->base_expression so
5857 that the corresponding tree temporary can be used as the base
5858 object in gfc_conv_procedure_call. */
5859 if (expr
->expr_type
!= EXPR_VARIABLE
)
5861 gfc_actual_arglist
*args
;
5863 args
= code
->expr1
->value
.function
.actual
;
5864 for (; args
; args
= args
->next
)
5865 if (expr
== args
->expr
)
5869 /* Since the typebound operators are generic, we have to ensure
5870 that any delays in resolution are corrected and that the vtab
5872 declared
= expr
->ts
.u
.derived
;
5873 c
= gfc_find_component (declared
, "_vptr", true, true);
5874 if (c
->ts
.u
.derived
== NULL
)
5875 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5877 if (!resolve_typebound_call (code
, &name
))
5880 /* Use the generic name if it is there. */
5881 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5882 code
->expr1
->symtree
= expr
->symtree
;
5883 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5885 /* Trim away the extraneous references that emerge from nested
5886 use of interface.c (extend_expr). */
5887 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5888 if (class_ref
&& class_ref
->next
)
5890 gfc_free_ref_list (class_ref
->next
);
5891 class_ref
->next
= NULL
;
5893 else if (code
->expr1
->ref
&& !class_ref
)
5895 gfc_free_ref_list (code
->expr1
->ref
);
5896 code
->expr1
->ref
= NULL
;
5899 /* Now use the procedure in the vtable. */
5900 gfc_add_vptr_component (code
->expr1
);
5901 gfc_add_component_ref (code
->expr1
, name
);
5902 code
->expr1
->value
.function
.esym
= NULL
;
5903 if (expr
->expr_type
!= EXPR_VARIABLE
)
5904 code
->expr1
->base_expr
= expr
;
5909 return resolve_typebound_call (code
, NULL
);
5911 if (!resolve_ref (code
->expr1
))
5914 /* Get the CLASS declared type. */
5915 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5917 /* Weed out cases of the ultimate component being a derived type. */
5918 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5919 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5921 gfc_free_ref_list (new_ref
);
5922 return resolve_typebound_call (code
, NULL
);
5925 if (!resolve_typebound_call (code
, &name
))
5927 gfc_free_ref_list (new_ref
);
5930 ts
= code
->expr1
->ts
;
5934 /* Convert the expression to a procedure pointer component call. */
5935 code
->expr1
->value
.function
.esym
= NULL
;
5936 code
->expr1
->symtree
= st
;
5939 code
->expr1
->ref
= new_ref
;
5941 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5942 gfc_add_vptr_component (code
->expr1
);
5943 gfc_add_component_ref (code
->expr1
, name
);
5945 /* Recover the typespec for the expression. This is really only
5946 necessary for generic procedures, where the additional call
5947 to gfc_add_component_ref seems to throw the collection of the
5948 correct typespec. */
5949 code
->expr1
->ts
= ts
;
5952 gfc_free_ref_list (new_ref
);
5958 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5961 resolve_ppc_call (gfc_code
* c
)
5963 gfc_component
*comp
;
5965 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
5966 gcc_assert (comp
!= NULL
);
5968 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5969 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5971 if (!comp
->attr
.subroutine
)
5972 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5974 if (!resolve_ref (c
->expr1
))
5977 if (!update_ppc_arglist (c
->expr1
))
5980 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5982 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5983 !(comp
->ts
.interface
5984 && comp
->ts
.interface
->formal
)))
5987 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5993 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5996 resolve_expr_ppc (gfc_expr
* e
)
5998 gfc_component
*comp
;
6000 comp
= gfc_get_proc_ptr_comp (e
);
6001 gcc_assert (comp
!= NULL
);
6003 /* Convert to EXPR_FUNCTION. */
6004 e
->expr_type
= EXPR_FUNCTION
;
6005 e
->value
.function
.isym
= NULL
;
6006 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6008 if (comp
->as
!= NULL
)
6009 e
->rank
= comp
->as
->rank
;
6011 if (!comp
->attr
.function
)
6012 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6014 if (!resolve_ref (e
))
6017 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6018 !(comp
->ts
.interface
6019 && comp
->ts
.interface
->formal
)))
6022 if (!update_ppc_arglist (e
))
6025 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6032 gfc_is_expandable_expr (gfc_expr
*e
)
6034 gfc_constructor
*con
;
6036 if (e
->expr_type
== EXPR_ARRAY
)
6038 /* Traverse the constructor looking for variables that are flavor
6039 parameter. Parameters must be expanded since they are fully used at
6041 con
= gfc_constructor_first (e
->value
.constructor
);
6042 for (; con
; con
= gfc_constructor_next (con
))
6044 if (con
->expr
->expr_type
== EXPR_VARIABLE
6045 && con
->expr
->symtree
6046 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6047 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6049 if (con
->expr
->expr_type
== EXPR_ARRAY
6050 && gfc_is_expandable_expr (con
->expr
))
6058 /* Resolve an expression. That is, make sure that types of operands agree
6059 with their operators, intrinsic operators are converted to function calls
6060 for overloaded types and unresolved function references are resolved. */
6063 gfc_resolve_expr (gfc_expr
*e
)
6066 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6071 /* inquiry_argument only applies to variables. */
6072 inquiry_save
= inquiry_argument
;
6073 actual_arg_save
= actual_arg
;
6074 first_actual_arg_save
= first_actual_arg
;
6076 if (e
->expr_type
!= EXPR_VARIABLE
)
6078 inquiry_argument
= false;
6080 first_actual_arg
= false;
6083 switch (e
->expr_type
)
6086 t
= resolve_operator (e
);
6092 if (check_host_association (e
))
6093 t
= resolve_function (e
);
6096 t
= resolve_variable (e
);
6098 expression_rank (e
);
6101 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6102 && e
->ref
->type
!= REF_SUBSTRING
)
6103 gfc_resolve_substring_charlen (e
);
6108 t
= resolve_typebound_function (e
);
6111 case EXPR_SUBSTRING
:
6112 t
= resolve_ref (e
);
6121 t
= resolve_expr_ppc (e
);
6126 if (!resolve_ref (e
))
6129 t
= gfc_resolve_array_constructor (e
);
6130 /* Also try to expand a constructor. */
6133 expression_rank (e
);
6134 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6135 gfc_expand_constructor (e
, false);
6138 /* This provides the opportunity for the length of constructors with
6139 character valued function elements to propagate the string length
6140 to the expression. */
6141 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6143 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6144 here rather then add a duplicate test for it above. */
6145 gfc_expand_constructor (e
, false);
6146 t
= gfc_resolve_character_array_constructor (e
);
6151 case EXPR_STRUCTURE
:
6152 t
= resolve_ref (e
);
6156 t
= resolve_structure_cons (e
, 0);
6160 t
= gfc_simplify_expr (e
, 0);
6164 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6167 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6170 inquiry_argument
= inquiry_save
;
6171 actual_arg
= actual_arg_save
;
6172 first_actual_arg
= first_actual_arg_save
;
6178 /* Resolve an expression from an iterator. They must be scalar and have
6179 INTEGER or (optionally) REAL type. */
6182 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6183 const char *name_msgid
)
6185 if (!gfc_resolve_expr (expr
))
6188 if (expr
->rank
!= 0)
6190 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6194 if (expr
->ts
.type
!= BT_INTEGER
)
6196 if (expr
->ts
.type
== BT_REAL
)
6199 return gfc_notify_std (GFC_STD_F95_DEL
,
6200 "%s at %L must be integer",
6201 _(name_msgid
), &expr
->where
);
6204 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6211 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6219 /* Resolve the expressions in an iterator structure. If REAL_OK is
6220 false allow only INTEGER type iterators, otherwise allow REAL types.
6221 Set own_scope to true for ac-implied-do and data-implied-do as those
6222 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6225 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6227 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6230 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6231 _("iterator variable")))
6234 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6235 "Start expression in DO loop"))
6238 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6239 "End expression in DO loop"))
6242 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6243 "Step expression in DO loop"))
6246 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6248 if ((iter
->step
->ts
.type
== BT_INTEGER
6249 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6250 || (iter
->step
->ts
.type
== BT_REAL
6251 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6253 gfc_error ("Step expression in DO loop at %L cannot be zero",
6254 &iter
->step
->where
);
6259 /* Convert start, end, and step to the same type as var. */
6260 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6261 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6262 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6264 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6265 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6266 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6268 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6269 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6270 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6272 if (iter
->start
->expr_type
== EXPR_CONSTANT
6273 && iter
->end
->expr_type
== EXPR_CONSTANT
6274 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6277 if (iter
->start
->ts
.type
== BT_INTEGER
)
6279 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6280 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6284 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6285 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6287 if (gfc_option
.warn_zerotrip
&&
6288 ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6289 gfc_warning ("DO loop at %L will be executed zero times"
6290 " (use -Wno-zerotrip to suppress)",
6291 &iter
->step
->where
);
6298 /* Traversal function for find_forall_index. f == 2 signals that
6299 that variable itself is not to be checked - only the references. */
6302 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6304 if (expr
->expr_type
!= EXPR_VARIABLE
)
6307 /* A scalar assignment */
6308 if (!expr
->ref
|| *f
== 1)
6310 if (expr
->symtree
->n
.sym
== sym
)
6322 /* Check whether the FORALL index appears in the expression or not.
6323 Returns true if SYM is found in EXPR. */
6326 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6328 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6335 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6336 to be a scalar INTEGER variable. The subscripts and stride are scalar
6337 INTEGERs, and if stride is a constant it must be nonzero.
6338 Furthermore "A subscript or stride in a forall-triplet-spec shall
6339 not contain a reference to any index-name in the
6340 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6343 resolve_forall_iterators (gfc_forall_iterator
*it
)
6345 gfc_forall_iterator
*iter
, *iter2
;
6347 for (iter
= it
; iter
; iter
= iter
->next
)
6349 if (gfc_resolve_expr (iter
->var
)
6350 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6351 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6354 if (gfc_resolve_expr (iter
->start
)
6355 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6356 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6357 &iter
->start
->where
);
6358 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6359 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6361 if (gfc_resolve_expr (iter
->end
)
6362 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6363 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6365 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6366 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6368 if (gfc_resolve_expr (iter
->stride
))
6370 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6371 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6372 &iter
->stride
->where
, "INTEGER");
6374 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6375 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6376 gfc_error ("FORALL stride expression at %L cannot be zero",
6377 &iter
->stride
->where
);
6379 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6380 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6383 for (iter
= it
; iter
; iter
= iter
->next
)
6384 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6386 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6387 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6388 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6389 gfc_error ("FORALL index '%s' may not appear in triplet "
6390 "specification at %L", iter
->var
->symtree
->name
,
6391 &iter2
->start
->where
);
6396 /* Given a pointer to a symbol that is a derived type, see if it's
6397 inaccessible, i.e. if it's defined in another module and the components are
6398 PRIVATE. The search is recursive if necessary. Returns zero if no
6399 inaccessible components are found, nonzero otherwise. */
6402 derived_inaccessible (gfc_symbol
*sym
)
6406 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6409 for (c
= sym
->components
; c
; c
= c
->next
)
6411 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6419 /* Resolve the argument of a deallocate expression. The expression must be
6420 a pointer or a full array. */
6423 resolve_deallocate_expr (gfc_expr
*e
)
6425 symbol_attribute attr
;
6426 int allocatable
, pointer
;
6432 if (!gfc_resolve_expr (e
))
6435 if (e
->expr_type
!= EXPR_VARIABLE
)
6438 sym
= e
->symtree
->n
.sym
;
6439 unlimited
= UNLIMITED_POLY(sym
);
6441 if (sym
->ts
.type
== BT_CLASS
)
6443 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6444 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6448 allocatable
= sym
->attr
.allocatable
;
6449 pointer
= sym
->attr
.pointer
;
6451 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6456 if (ref
->u
.ar
.type
!= AR_FULL
6457 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6458 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6463 c
= ref
->u
.c
.component
;
6464 if (c
->ts
.type
== BT_CLASS
)
6466 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6467 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6471 allocatable
= c
->attr
.allocatable
;
6472 pointer
= c
->attr
.pointer
;
6482 attr
= gfc_expr_attr (e
);
6484 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6487 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6493 if (gfc_is_coindexed (e
))
6495 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6500 && !gfc_check_vardef_context (e
, true, true, false,
6501 _("DEALLOCATE object")))
6503 if (!gfc_check_vardef_context (e
, false, true, false,
6504 _("DEALLOCATE object")))
6511 /* Returns true if the expression e contains a reference to the symbol sym. */
6513 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6515 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6522 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6524 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6528 /* Given the expression node e for an allocatable/pointer of derived type to be
6529 allocated, get the expression node to be initialized afterwards (needed for
6530 derived types with default initializers, and derived types with allocatable
6531 components that need nullification.) */
6534 gfc_expr_to_initialize (gfc_expr
*e
)
6540 result
= gfc_copy_expr (e
);
6542 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6543 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6544 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6546 ref
->u
.ar
.type
= AR_FULL
;
6548 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6549 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6554 gfc_free_shape (&result
->shape
, result
->rank
);
6556 /* Recalculate rank, shape, etc. */
6557 gfc_resolve_expr (result
);
6562 /* If the last ref of an expression is an array ref, return a copy of the
6563 expression with that one removed. Otherwise, a copy of the original
6564 expression. This is used for allocate-expressions and pointer assignment
6565 LHS, where there may be an array specification that needs to be stripped
6566 off when using gfc_check_vardef_context. */
6569 remove_last_array_ref (gfc_expr
* e
)
6574 e2
= gfc_copy_expr (e
);
6575 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6576 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6578 gfc_free_ref_list (*r
);
6587 /* Used in resolve_allocate_expr to check that a allocation-object and
6588 a source-expr are conformable. This does not catch all possible
6589 cases; in particular a runtime checking is needed. */
6592 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6595 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6597 /* First compare rank. */
6598 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6599 || (!tail
&& e1
->rank
!= e2
->rank
))
6601 gfc_error ("Source-expr at %L must be scalar or have the "
6602 "same rank as the allocate-object at %L",
6603 &e1
->where
, &e2
->where
);
6614 for (i
= 0; i
< e1
->rank
; i
++)
6616 if (tail
->u
.ar
.start
[i
] == NULL
)
6619 if (tail
->u
.ar
.end
[i
])
6621 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6622 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6623 mpz_add_ui (s
, s
, 1);
6627 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6630 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6632 gfc_error ("Source-expr at %L and allocate-object at %L must "
6633 "have the same shape", &e1
->where
, &e2
->where
);
6646 /* Resolve the expression in an ALLOCATE statement, doing the additional
6647 checks to see whether the expression is OK or not. The expression must
6648 have a trailing array reference that gives the size of the array. */
6651 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6653 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6657 symbol_attribute attr
;
6658 gfc_ref
*ref
, *ref2
;
6661 gfc_symbol
*sym
= NULL
;
6666 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6667 checking of coarrays. */
6668 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6669 if (ref
->next
== NULL
)
6672 if (ref
&& ref
->type
== REF_ARRAY
)
6673 ref
->u
.ar
.in_allocate
= true;
6675 if (!gfc_resolve_expr (e
))
6678 /* Make sure the expression is allocatable or a pointer. If it is
6679 pointer, the next-to-last reference must be a pointer. */
6683 sym
= e
->symtree
->n
.sym
;
6685 /* Check whether ultimate component is abstract and CLASS. */
6688 /* Is the allocate-object unlimited polymorphic? */
6689 unlimited
= UNLIMITED_POLY(e
);
6691 if (e
->expr_type
!= EXPR_VARIABLE
)
6694 attr
= gfc_expr_attr (e
);
6695 pointer
= attr
.pointer
;
6696 dimension
= attr
.dimension
;
6697 codimension
= attr
.codimension
;
6701 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6703 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6704 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6705 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6706 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6707 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6711 allocatable
= sym
->attr
.allocatable
;
6712 pointer
= sym
->attr
.pointer
;
6713 dimension
= sym
->attr
.dimension
;
6714 codimension
= sym
->attr
.codimension
;
6719 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6724 if (ref
->u
.ar
.codimen
> 0)
6727 for (n
= ref
->u
.ar
.dimen
;
6728 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6729 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6736 if (ref
->next
!= NULL
)
6744 gfc_error ("Coindexed allocatable object at %L",
6749 c
= ref
->u
.c
.component
;
6750 if (c
->ts
.type
== BT_CLASS
)
6752 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6753 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6754 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6755 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6756 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6760 allocatable
= c
->attr
.allocatable
;
6761 pointer
= c
->attr
.pointer
;
6762 dimension
= c
->attr
.dimension
;
6763 codimension
= c
->attr
.codimension
;
6764 is_abstract
= c
->attr
.abstract
;
6776 /* Check for F08:C628. */
6777 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6779 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6784 /* Some checks for the SOURCE tag. */
6787 /* Check F03:C631. */
6788 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6790 gfc_error ("Type of entity at %L is type incompatible with "
6791 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6795 /* Check F03:C632 and restriction following Note 6.18. */
6796 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6799 /* Check F03:C633. */
6800 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6802 gfc_error ("The allocate-object at %L and the source-expr at %L "
6803 "shall have the same kind type parameter",
6804 &e
->where
, &code
->expr3
->where
);
6808 /* Check F2008, C642. */
6809 if (code
->expr3
->ts
.type
== BT_DERIVED
6810 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6811 || (code
->expr3
->ts
.u
.derived
->from_intmod
6812 == INTMOD_ISO_FORTRAN_ENV
6813 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6814 == ISOFORTRAN_LOCK_TYPE
)))
6816 gfc_error ("The source-expr at %L shall neither be of type "
6817 "LOCK_TYPE nor have a LOCK_TYPE component if "
6818 "allocate-object at %L is a coarray",
6819 &code
->expr3
->where
, &e
->where
);
6824 /* Check F08:C629. */
6825 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6828 gcc_assert (e
->ts
.type
== BT_CLASS
);
6829 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6830 "type-spec or source-expr", sym
->name
, &e
->where
);
6834 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6836 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6837 code
->ext
.alloc
.ts
.u
.cl
->length
);
6838 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6840 gfc_error ("Allocating %s at %L with type-spec requires the same "
6841 "character-length parameter as in the declaration",
6842 sym
->name
, &e
->where
);
6847 /* In the variable definition context checks, gfc_expr_attr is used
6848 on the expression. This is fooled by the array specification
6849 present in e, thus we have to eliminate that one temporarily. */
6850 e2
= remove_last_array_ref (e
);
6853 t
= gfc_check_vardef_context (e2
, true, true, false,
6854 _("ALLOCATE object"));
6856 t
= gfc_check_vardef_context (e2
, false, true, false,
6857 _("ALLOCATE object"));
6862 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6863 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6865 /* For class arrays, the initialization with SOURCE is done
6866 using _copy and trans_call. It is convenient to exploit that
6867 when the allocated type is different from the declared type but
6868 no SOURCE exists by setting expr3. */
6869 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6871 else if (!code
->expr3
)
6873 /* Set up default initializer if needed. */
6877 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6878 ts
= code
->ext
.alloc
.ts
;
6882 if (ts
.type
== BT_CLASS
)
6883 ts
= ts
.u
.derived
->components
->ts
;
6885 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6887 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6888 init_st
->loc
= code
->loc
;
6889 init_st
->expr1
= gfc_expr_to_initialize (e
);
6890 init_st
->expr2
= init_e
;
6891 init_st
->next
= code
->next
;
6892 code
->next
= init_st
;
6895 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6897 /* Default initialization via MOLD (non-polymorphic). */
6898 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6899 gfc_resolve_expr (rhs
);
6900 gfc_free_expr (code
->expr3
);
6904 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6906 /* Make sure the vtab symbol is present when
6907 the module variables are generated. */
6908 gfc_typespec ts
= e
->ts
;
6910 ts
= code
->expr3
->ts
;
6911 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6912 ts
= code
->ext
.alloc
.ts
;
6914 gfc_find_derived_vtab (ts
.u
.derived
);
6917 e
= gfc_expr_to_initialize (e
);
6919 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6921 /* Again, make sure the vtab symbol is present when
6922 the module variables are generated. */
6923 gfc_typespec
*ts
= NULL
;
6925 ts
= &code
->expr3
->ts
;
6927 ts
= &code
->ext
.alloc
.ts
;
6934 e
= gfc_expr_to_initialize (e
);
6937 if (dimension
== 0 && codimension
== 0)
6940 /* Make sure the last reference node is an array specification. */
6942 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6943 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6945 gfc_error ("Array specification required in ALLOCATE statement "
6946 "at %L", &e
->where
);
6950 /* Make sure that the array section reference makes sense in the
6951 context of an ALLOCATE specification. */
6956 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6957 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6959 gfc_error ("Coarray specification required in ALLOCATE statement "
6960 "at %L", &e
->where
);
6964 for (i
= 0; i
< ar
->dimen
; i
++)
6966 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6969 switch (ar
->dimen_type
[i
])
6975 if (ar
->start
[i
] != NULL
6976 && ar
->end
[i
] != NULL
6977 && ar
->stride
[i
] == NULL
)
6980 /* Fall Through... */
6985 case DIMEN_THIS_IMAGE
:
6986 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6992 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6994 sym
= a
->expr
->symtree
->n
.sym
;
6996 /* TODO - check derived type components. */
6997 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7000 if ((ar
->start
[i
] != NULL
7001 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7002 || (ar
->end
[i
] != NULL
7003 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7005 gfc_error ("'%s' must not appear in the array specification at "
7006 "%L in the same ALLOCATE statement where it is "
7007 "itself allocated", sym
->name
, &ar
->where
);
7013 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7015 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7016 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7018 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7020 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7021 "statement at %L", &e
->where
);
7027 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7028 && ar
->stride
[i
] == NULL
)
7031 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7044 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7046 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7047 gfc_alloc
*a
, *p
, *q
;
7050 errmsg
= code
->expr2
;
7052 /* Check the stat variable. */
7055 gfc_check_vardef_context (stat
, false, false, false,
7056 _("STAT variable"));
7058 if ((stat
->ts
.type
!= BT_INTEGER
7059 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7060 || stat
->ref
->type
== REF_COMPONENT
)))
7062 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7063 "variable", &stat
->where
);
7065 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7066 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7068 gfc_ref
*ref1
, *ref2
;
7071 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7072 ref1
= ref1
->next
, ref2
= ref2
->next
)
7074 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7076 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7085 gfc_error ("Stat-variable at %L shall not be %sd within "
7086 "the same %s statement", &stat
->where
, fcn
, fcn
);
7092 /* Check the errmsg variable. */
7096 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7099 gfc_check_vardef_context (errmsg
, false, false, false,
7100 _("ERRMSG variable"));
7102 if ((errmsg
->ts
.type
!= BT_CHARACTER
7104 && (errmsg
->ref
->type
== REF_ARRAY
7105 || errmsg
->ref
->type
== REF_COMPONENT
)))
7106 || errmsg
->rank
> 0 )
7107 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7108 "variable", &errmsg
->where
);
7110 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7111 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7113 gfc_ref
*ref1
, *ref2
;
7116 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7117 ref1
= ref1
->next
, ref2
= ref2
->next
)
7119 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7121 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7130 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7131 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7137 /* Check that an allocate-object appears only once in the statement. */
7139 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7142 for (q
= p
->next
; q
; q
= q
->next
)
7145 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7147 /* This is a potential collision. */
7148 gfc_ref
*pr
= pe
->ref
;
7149 gfc_ref
*qr
= qe
->ref
;
7151 /* Follow the references until
7152 a) They start to differ, in which case there is no error;
7153 you can deallocate a%b and a%c in a single statement
7154 b) Both of them stop, which is an error
7155 c) One of them stops, which is also an error. */
7158 if (pr
== NULL
&& qr
== NULL
)
7160 gfc_error ("Allocate-object at %L also appears at %L",
7161 &pe
->where
, &qe
->where
);
7164 else if (pr
!= NULL
&& qr
== NULL
)
7166 gfc_error ("Allocate-object at %L is subobject of"
7167 " object at %L", &pe
->where
, &qe
->where
);
7170 else if (pr
== NULL
&& qr
!= NULL
)
7172 gfc_error ("Allocate-object at %L is subobject of"
7173 " object at %L", &qe
->where
, &pe
->where
);
7176 /* Here, pr != NULL && qr != NULL */
7177 gcc_assert(pr
->type
== qr
->type
);
7178 if (pr
->type
== REF_ARRAY
)
7180 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7182 gcc_assert (qr
->type
== REF_ARRAY
);
7184 if (pr
->next
&& qr
->next
)
7187 gfc_array_ref
*par
= &(pr
->u
.ar
);
7188 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7190 for (i
=0; i
<par
->dimen
; i
++)
7192 if ((par
->start
[i
] != NULL
7193 || qar
->start
[i
] != NULL
)
7194 && gfc_dep_compare_expr (par
->start
[i
],
7195 qar
->start
[i
]) != 0)
7202 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7215 if (strcmp (fcn
, "ALLOCATE") == 0)
7217 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7218 resolve_allocate_expr (a
->expr
, code
);
7222 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7223 resolve_deallocate_expr (a
->expr
);
7228 /************ SELECT CASE resolution subroutines ************/
7230 /* Callback function for our mergesort variant. Determines interval
7231 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7232 op1 > op2. Assumes we're not dealing with the default case.
7233 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7234 There are nine situations to check. */
7237 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7241 if (op1
->low
== NULL
) /* op1 = (:L) */
7243 /* op2 = (:N), so overlap. */
7245 /* op2 = (M:) or (M:N), L < M */
7246 if (op2
->low
!= NULL
7247 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7250 else if (op1
->high
== NULL
) /* op1 = (K:) */
7252 /* op2 = (M:), so overlap. */
7254 /* op2 = (:N) or (M:N), K > N */
7255 if (op2
->high
!= NULL
7256 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7259 else /* op1 = (K:L) */
7261 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7262 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7264 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7265 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7267 else /* op2 = (M:N) */
7271 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7274 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7283 /* Merge-sort a double linked case list, detecting overlap in the
7284 process. LIST is the head of the double linked case list before it
7285 is sorted. Returns the head of the sorted list if we don't see any
7286 overlap, or NULL otherwise. */
7289 check_case_overlap (gfc_case
*list
)
7291 gfc_case
*p
, *q
, *e
, *tail
;
7292 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7294 /* If the passed list was empty, return immediately. */
7301 /* Loop unconditionally. The only exit from this loop is a return
7302 statement, when we've finished sorting the case list. */
7309 /* Count the number of merges we do in this pass. */
7312 /* Loop while there exists a merge to be done. */
7317 /* Count this merge. */
7320 /* Cut the list in two pieces by stepping INSIZE places
7321 forward in the list, starting from P. */
7324 for (i
= 0; i
< insize
; i
++)
7333 /* Now we have two lists. Merge them! */
7334 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7336 /* See from which the next case to merge comes from. */
7339 /* P is empty so the next case must come from Q. */
7344 else if (qsize
== 0 || q
== NULL
)
7353 cmp
= compare_cases (p
, q
);
7356 /* The whole case range for P is less than the
7364 /* The whole case range for Q is greater than
7365 the case range for P. */
7372 /* The cases overlap, or they are the same
7373 element in the list. Either way, we must
7374 issue an error and get the next case from P. */
7375 /* FIXME: Sort P and Q by line number. */
7376 gfc_error ("CASE label at %L overlaps with CASE "
7377 "label at %L", &p
->where
, &q
->where
);
7385 /* Add the next element to the merged list. */
7394 /* P has now stepped INSIZE places along, and so has Q. So
7395 they're the same. */
7400 /* If we have done only one merge or none at all, we've
7401 finished sorting the cases. */
7410 /* Otherwise repeat, merging lists twice the size. */
7416 /* Check to see if an expression is suitable for use in a CASE statement.
7417 Makes sure that all case expressions are scalar constants of the same
7418 type. Return false if anything is wrong. */
7421 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7423 if (e
== NULL
) return true;
7425 if (e
->ts
.type
!= case_expr
->ts
.type
)
7427 gfc_error ("Expression in CASE statement at %L must be of type %s",
7428 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7432 /* C805 (R808) For a given case-construct, each case-value shall be of
7433 the same type as case-expr. For character type, length differences
7434 are allowed, but the kind type parameters shall be the same. */
7436 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7438 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7439 &e
->where
, case_expr
->ts
.kind
);
7443 /* Convert the case value kind to that of case expression kind,
7446 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7447 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7451 gfc_error ("Expression in CASE statement at %L must be scalar",
7460 /* Given a completely parsed select statement, we:
7462 - Validate all expressions and code within the SELECT.
7463 - Make sure that the selection expression is not of the wrong type.
7464 - Make sure that no case ranges overlap.
7465 - Eliminate unreachable cases and unreachable code resulting from
7466 removing case labels.
7468 The standard does allow unreachable cases, e.g. CASE (5:3). But
7469 they are a hassle for code generation, and to prevent that, we just
7470 cut them out here. This is not necessary for overlapping cases
7471 because they are illegal and we never even try to generate code.
7473 We have the additional caveat that a SELECT construct could have
7474 been a computed GOTO in the source code. Fortunately we can fairly
7475 easily work around that here: The case_expr for a "real" SELECT CASE
7476 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7477 we have to do is make sure that the case_expr is a scalar integer
7481 resolve_select (gfc_code
*code
, bool select_type
)
7484 gfc_expr
*case_expr
;
7485 gfc_case
*cp
, *default_case
, *tail
, *head
;
7486 int seen_unreachable
;
7492 if (code
->expr1
== NULL
)
7494 /* This was actually a computed GOTO statement. */
7495 case_expr
= code
->expr2
;
7496 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7497 gfc_error ("Selection expression in computed GOTO statement "
7498 "at %L must be a scalar integer expression",
7501 /* Further checking is not necessary because this SELECT was built
7502 by the compiler, so it should always be OK. Just move the
7503 case_expr from expr2 to expr so that we can handle computed
7504 GOTOs as normal SELECTs from here on. */
7505 code
->expr1
= code
->expr2
;
7510 case_expr
= code
->expr1
;
7511 type
= case_expr
->ts
.type
;
7514 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7516 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7517 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7519 /* Punt. Going on here just produce more garbage error messages. */
7524 if (!select_type
&& case_expr
->rank
!= 0)
7526 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7527 "expression", &case_expr
->where
);
7533 /* Raise a warning if an INTEGER case value exceeds the range of
7534 the case-expr. Later, all expressions will be promoted to the
7535 largest kind of all case-labels. */
7537 if (type
== BT_INTEGER
)
7538 for (body
= code
->block
; body
; body
= body
->block
)
7539 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7542 && gfc_check_integer_range (cp
->low
->value
.integer
,
7543 case_expr
->ts
.kind
) != ARITH_OK
)
7544 gfc_warning ("Expression in CASE statement at %L is "
7545 "not in the range of %s", &cp
->low
->where
,
7546 gfc_typename (&case_expr
->ts
));
7549 && cp
->low
!= cp
->high
7550 && gfc_check_integer_range (cp
->high
->value
.integer
,
7551 case_expr
->ts
.kind
) != ARITH_OK
)
7552 gfc_warning ("Expression in CASE statement at %L is "
7553 "not in the range of %s", &cp
->high
->where
,
7554 gfc_typename (&case_expr
->ts
));
7557 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7558 of the SELECT CASE expression and its CASE values. Walk the lists
7559 of case values, and if we find a mismatch, promote case_expr to
7560 the appropriate kind. */
7562 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7564 for (body
= code
->block
; body
; body
= body
->block
)
7566 /* Walk the case label list. */
7567 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7569 /* Intercept the DEFAULT case. It does not have a kind. */
7570 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7573 /* Unreachable case ranges are discarded, so ignore. */
7574 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7575 && cp
->low
!= cp
->high
7576 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7580 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7581 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7583 if (cp
->high
!= NULL
7584 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7585 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7590 /* Assume there is no DEFAULT case. */
7591 default_case
= NULL
;
7596 for (body
= code
->block
; body
; body
= body
->block
)
7598 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7600 seen_unreachable
= 0;
7602 /* Walk the case label list, making sure that all case labels
7604 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7606 /* Count the number of cases in the whole construct. */
7609 /* Intercept the DEFAULT case. */
7610 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7612 if (default_case
!= NULL
)
7614 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7615 "by a second DEFAULT CASE at %L",
7616 &default_case
->where
, &cp
->where
);
7627 /* Deal with single value cases and case ranges. Errors are
7628 issued from the validation function. */
7629 if (!validate_case_label_expr (cp
->low
, case_expr
)
7630 || !validate_case_label_expr (cp
->high
, case_expr
))
7636 if (type
== BT_LOGICAL
7637 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7638 || cp
->low
!= cp
->high
))
7640 gfc_error ("Logical range in CASE statement at %L is not "
7641 "allowed", &cp
->low
->where
);
7646 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7649 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7650 if (value
& seen_logical
)
7652 gfc_error ("Constant logical value in CASE statement "
7653 "is repeated at %L",
7658 seen_logical
|= value
;
7661 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7662 && cp
->low
!= cp
->high
7663 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7665 if (gfc_option
.warn_surprising
)
7666 gfc_warning ("Range specification at %L can never "
7667 "be matched", &cp
->where
);
7669 cp
->unreachable
= 1;
7670 seen_unreachable
= 1;
7674 /* If the case range can be matched, it can also overlap with
7675 other cases. To make sure it does not, we put it in a
7676 double linked list here. We sort that with a merge sort
7677 later on to detect any overlapping cases. */
7681 head
->right
= head
->left
= NULL
;
7686 tail
->right
->left
= tail
;
7693 /* It there was a failure in the previous case label, give up
7694 for this case label list. Continue with the next block. */
7698 /* See if any case labels that are unreachable have been seen.
7699 If so, we eliminate them. This is a bit of a kludge because
7700 the case lists for a single case statement (label) is a
7701 single forward linked lists. */
7702 if (seen_unreachable
)
7704 /* Advance until the first case in the list is reachable. */
7705 while (body
->ext
.block
.case_list
!= NULL
7706 && body
->ext
.block
.case_list
->unreachable
)
7708 gfc_case
*n
= body
->ext
.block
.case_list
;
7709 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7711 gfc_free_case_list (n
);
7714 /* Strip all other unreachable cases. */
7715 if (body
->ext
.block
.case_list
)
7717 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7719 if (cp
->next
->unreachable
)
7721 gfc_case
*n
= cp
->next
;
7722 cp
->next
= cp
->next
->next
;
7724 gfc_free_case_list (n
);
7731 /* See if there were overlapping cases. If the check returns NULL,
7732 there was overlap. In that case we don't do anything. If head
7733 is non-NULL, we prepend the DEFAULT case. The sorted list can
7734 then used during code generation for SELECT CASE constructs with
7735 a case expression of a CHARACTER type. */
7738 head
= check_case_overlap (head
);
7740 /* Prepend the default_case if it is there. */
7741 if (head
!= NULL
&& default_case
)
7743 default_case
->left
= NULL
;
7744 default_case
->right
= head
;
7745 head
->left
= default_case
;
7749 /* Eliminate dead blocks that may be the result if we've seen
7750 unreachable case labels for a block. */
7751 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7753 if (body
->block
->ext
.block
.case_list
== NULL
)
7755 /* Cut the unreachable block from the code chain. */
7756 gfc_code
*c
= body
->block
;
7757 body
->block
= c
->block
;
7759 /* Kill the dead block, but not the blocks below it. */
7761 gfc_free_statements (c
);
7765 /* More than two cases is legal but insane for logical selects.
7766 Issue a warning for it. */
7767 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7769 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7774 /* Check if a derived type is extensible. */
7777 gfc_type_is_extensible (gfc_symbol
*sym
)
7779 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7780 || (sym
->attr
.is_class
7781 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7785 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7786 correct as well as possibly the array-spec. */
7789 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7793 gcc_assert (sym
->assoc
);
7794 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7796 /* If this is for SELECT TYPE, the target may not yet be set. In that
7797 case, return. Resolution will be called later manually again when
7799 target
= sym
->assoc
->target
;
7802 gcc_assert (!sym
->assoc
->dangling
);
7804 if (resolve_target
&& !gfc_resolve_expr (target
))
7807 /* For variable targets, we get some attributes from the target. */
7808 if (target
->expr_type
== EXPR_VARIABLE
)
7812 gcc_assert (target
->symtree
);
7813 tsym
= target
->symtree
->n
.sym
;
7815 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7816 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7818 sym
->attr
.target
= tsym
->attr
.target
7819 || gfc_expr_attr (target
).pointer
;
7820 if (is_subref_array (target
))
7821 sym
->attr
.subref_array_pointer
= 1;
7824 /* Get type if this was not already set. Note that it can be
7825 some other type than the target in case this is a SELECT TYPE
7826 selector! So we must not update when the type is already there. */
7827 if (sym
->ts
.type
== BT_UNKNOWN
)
7828 sym
->ts
= target
->ts
;
7829 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7831 /* See if this is a valid association-to-variable. */
7832 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7833 && !gfc_has_vector_subscript (target
));
7835 /* Finally resolve if this is an array or not. */
7836 if (sym
->attr
.dimension
&& target
->rank
== 0)
7838 gfc_error ("Associate-name '%s' at %L is used as array",
7839 sym
->name
, &sym
->declared_at
);
7840 sym
->attr
.dimension
= 0;
7844 /* We cannot deal with class selectors that need temporaries. */
7845 if (target
->ts
.type
== BT_CLASS
7846 && gfc_ref_needs_temporary_p (target
->ref
))
7848 gfc_error ("CLASS selector at %L needs a temporary which is not "
7849 "yet implemented", &target
->where
);
7853 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7854 sym
->attr
.dimension
= 1;
7855 else if (target
->ts
.type
== BT_CLASS
)
7856 gfc_fix_class_refs (target
);
7858 /* The associate-name will have a correct type by now. Make absolutely
7859 sure that it has not picked up a dimension attribute. */
7860 if (sym
->ts
.type
== BT_CLASS
)
7861 sym
->attr
.dimension
= 0;
7863 if (sym
->attr
.dimension
)
7865 sym
->as
= gfc_get_array_spec ();
7866 sym
->as
->rank
= target
->rank
;
7867 sym
->as
->type
= AS_DEFERRED
;
7869 /* Target must not be coindexed, thus the associate-variable
7871 sym
->as
->corank
= 0;
7874 /* Mark this as an associate variable. */
7875 sym
->attr
.associate_var
= 1;
7877 /* If the target is a good class object, so is the associate variable. */
7878 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7879 sym
->attr
.class_ok
= 1;
7883 /* Resolve a SELECT TYPE statement. */
7886 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7888 gfc_symbol
*selector_type
;
7889 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7890 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7893 char name
[GFC_MAX_SYMBOL_LEN
];
7898 ns
= code
->ext
.block
.ns
;
7901 /* Check for F03:C813. */
7902 if (code
->expr1
->ts
.type
!= BT_CLASS
7903 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7905 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7906 "at %L", &code
->loc
);
7910 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7915 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7916 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7917 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7919 /* F2008: C803 The selector expression must not be coindexed. */
7920 if (gfc_is_coindexed (code
->expr2
))
7922 gfc_error ("Selector at %L must not be coindexed",
7923 &code
->expr2
->where
);
7930 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7932 if (gfc_is_coindexed (code
->expr1
))
7934 gfc_error ("Selector at %L must not be coindexed",
7935 &code
->expr1
->where
);
7940 /* Loop over TYPE IS / CLASS IS cases. */
7941 for (body
= code
->block
; body
; body
= body
->block
)
7943 c
= body
->ext
.block
.case_list
;
7945 /* Check F03:C815. */
7946 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7947 && !selector_type
->attr
.unlimited_polymorphic
7948 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7950 gfc_error ("Derived type '%s' at %L must be extensible",
7951 c
->ts
.u
.derived
->name
, &c
->where
);
7956 /* Check F03:C816. */
7957 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
7958 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
7959 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
7961 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7962 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7963 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7965 gfc_error ("Unexpected intrinsic type '%s' at %L",
7966 gfc_basic_typename (c
->ts
.type
), &c
->where
);
7971 /* Check F03:C814. */
7972 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
7974 gfc_error ("The type-spec at %L shall specify that each length "
7975 "type parameter is assumed", &c
->where
);
7980 /* Intercept the DEFAULT case. */
7981 if (c
->ts
.type
== BT_UNKNOWN
)
7983 /* Check F03:C818. */
7986 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7987 "by a second DEFAULT CASE at %L",
7988 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7993 default_case
= body
;
8000 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8001 target if present. If there are any EXIT statements referring to the
8002 SELECT TYPE construct, this is no problem because the gfc_code
8003 reference stays the same and EXIT is equally possible from the BLOCK
8004 it is changed to. */
8005 code
->op
= EXEC_BLOCK
;
8008 gfc_association_list
* assoc
;
8010 assoc
= gfc_get_association_list ();
8011 assoc
->st
= code
->expr1
->symtree
;
8012 assoc
->target
= gfc_copy_expr (code
->expr2
);
8013 assoc
->target
->where
= code
->expr2
->where
;
8014 /* assoc->variable will be set by resolve_assoc_var. */
8016 code
->ext
.block
.assoc
= assoc
;
8017 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8019 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8022 code
->ext
.block
.assoc
= NULL
;
8024 /* Add EXEC_SELECT to switch on type. */
8025 new_st
= gfc_get_code (code
->op
);
8026 new_st
->expr1
= code
->expr1
;
8027 new_st
->expr2
= code
->expr2
;
8028 new_st
->block
= code
->block
;
8029 code
->expr1
= code
->expr2
= NULL
;
8034 ns
->code
->next
= new_st
;
8036 code
->op
= EXEC_SELECT
;
8038 gfc_add_vptr_component (code
->expr1
);
8039 gfc_add_hash_component (code
->expr1
);
8041 /* Loop over TYPE IS / CLASS IS cases. */
8042 for (body
= code
->block
; body
; body
= body
->block
)
8044 c
= body
->ext
.block
.case_list
;
8046 if (c
->ts
.type
== BT_DERIVED
)
8047 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8048 c
->ts
.u
.derived
->hash_value
);
8049 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8054 ivtab
= gfc_find_vtab (&c
->ts
);
8055 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8056 e
= CLASS_DATA (ivtab
)->initializer
;
8057 c
->low
= c
->high
= gfc_copy_expr (e
);
8060 else if (c
->ts
.type
== BT_UNKNOWN
)
8063 /* Associate temporary to selector. This should only be done
8064 when this case is actually true, so build a new ASSOCIATE
8065 that does precisely this here (instead of using the
8068 if (c
->ts
.type
== BT_CLASS
)
8069 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8070 else if (c
->ts
.type
== BT_DERIVED
)
8071 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8072 else if (c
->ts
.type
== BT_CHARACTER
)
8074 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8075 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8076 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8077 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8078 charlen
, c
->ts
.kind
);
8081 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8084 st
= gfc_find_symtree (ns
->sym_root
, name
);
8085 gcc_assert (st
->n
.sym
->assoc
);
8086 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8087 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8088 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8089 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8091 new_st
= gfc_get_code (EXEC_BLOCK
);
8092 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8093 new_st
->ext
.block
.ns
->code
= body
->next
;
8094 body
->next
= new_st
;
8096 /* Chain in the new list only if it is marked as dangling. Otherwise
8097 there is a CASE label overlap and this is already used. Just ignore,
8098 the error is diagnosed elsewhere. */
8099 if (st
->n
.sym
->assoc
->dangling
)
8101 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8102 st
->n
.sym
->assoc
->dangling
= 0;
8105 resolve_assoc_var (st
->n
.sym
, false);
8108 /* Take out CLASS IS cases for separate treatment. */
8110 while (body
&& body
->block
)
8112 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8114 /* Add to class_is list. */
8115 if (class_is
== NULL
)
8117 class_is
= body
->block
;
8122 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8123 tail
->block
= body
->block
;
8126 /* Remove from EXEC_SELECT list. */
8127 body
->block
= body
->block
->block
;
8140 /* Add a default case to hold the CLASS IS cases. */
8141 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8142 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8144 tail
->ext
.block
.case_list
= gfc_get_case ();
8145 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8147 default_case
= tail
;
8150 /* More than one CLASS IS block? */
8151 if (class_is
->block
)
8155 /* Sort CLASS IS blocks by extension level. */
8159 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8162 /* F03:C817 (check for doubles). */
8163 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8164 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8166 gfc_error ("Double CLASS IS block in SELECT TYPE "
8168 &c2
->ext
.block
.case_list
->where
);
8171 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8172 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8175 (*c1
)->block
= c2
->block
;
8185 /* Generate IF chain. */
8186 if_st
= gfc_get_code (EXEC_IF
);
8188 for (body
= class_is
; body
; body
= body
->block
)
8190 new_st
->block
= gfc_get_code (EXEC_IF
);
8191 new_st
= new_st
->block
;
8192 /* Set up IF condition: Call _gfortran_is_extension_of. */
8193 new_st
->expr1
= gfc_get_expr ();
8194 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8195 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8196 new_st
->expr1
->ts
.kind
= 4;
8197 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8198 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8199 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8200 /* Set up arguments. */
8201 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8202 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8203 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8204 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8205 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8206 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8207 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8208 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8209 new_st
->next
= body
->next
;
8211 if (default_case
->next
)
8213 new_st
->block
= gfc_get_code (EXEC_IF
);
8214 new_st
= new_st
->block
;
8215 new_st
->next
= default_case
->next
;
8218 /* Replace CLASS DEFAULT code by the IF chain. */
8219 default_case
->next
= if_st
;
8222 /* Resolve the internal code. This can not be done earlier because
8223 it requires that the sym->assoc of selectors is set already. */
8224 gfc_current_ns
= ns
;
8225 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8226 gfc_current_ns
= old_ns
;
8228 resolve_select (code
, true);
8232 /* Resolve a transfer statement. This is making sure that:
8233 -- a derived type being transferred has only non-pointer components
8234 -- a derived type being transferred doesn't have private components, unless
8235 it's being transferred from the module where the type was defined
8236 -- we're not trying to transfer a whole assumed size array. */
8239 resolve_transfer (gfc_code
*code
)
8248 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8249 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8250 exp
= exp
->value
.op
.op1
;
8252 if (exp
&& exp
->expr_type
== EXPR_NULL
8255 gfc_error ("Invalid context for NULL () intrinsic at %L",
8260 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8261 && exp
->expr_type
!= EXPR_FUNCTION
))
8264 /* If we are reading, the variable will be changed. Note that
8265 code->ext.dt may be NULL if the TRANSFER is related to
8266 an INQUIRE statement -- but in this case, we are not reading, either. */
8267 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8268 && !gfc_check_vardef_context (exp
, false, false, false,
8272 sym
= exp
->symtree
->n
.sym
;
8275 /* Go to actual component transferred. */
8276 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8277 if (ref
->type
== REF_COMPONENT
)
8278 ts
= &ref
->u
.c
.component
->ts
;
8280 if (ts
->type
== BT_CLASS
)
8282 /* FIXME: Test for defined input/output. */
8283 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8284 "it is processed by a defined input/output procedure",
8289 if (ts
->type
== BT_DERIVED
)
8291 /* Check that transferred derived type doesn't contain POINTER
8293 if (ts
->u
.derived
->attr
.pointer_comp
)
8295 gfc_error ("Data transfer element at %L cannot have POINTER "
8296 "components unless it is processed by a defined "
8297 "input/output procedure", &code
->loc
);
8302 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8304 gfc_error ("Data transfer element at %L cannot have "
8305 "procedure pointer components", &code
->loc
);
8309 if (ts
->u
.derived
->attr
.alloc_comp
)
8311 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8312 "components unless it is processed by a defined "
8313 "input/output procedure", &code
->loc
);
8317 /* C_PTR and C_FUNPTR have private components which means they can not
8318 be printed. However, if -std=gnu and not -pedantic, allow
8319 the component to be printed to help debugging. */
8320 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8322 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8323 "cannot have PRIVATE components", &code
->loc
))
8326 else if (derived_inaccessible (ts
->u
.derived
))
8328 gfc_error ("Data transfer element at %L cannot have "
8329 "PRIVATE components",&code
->loc
);
8334 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8335 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8337 gfc_error ("Data transfer element at %L cannot be a full reference to "
8338 "an assumed-size array", &code
->loc
);
8344 /*********** Toplevel code resolution subroutines ***********/
8346 /* Find the set of labels that are reachable from this block. We also
8347 record the last statement in each block. */
8350 find_reachable_labels (gfc_code
*block
)
8357 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8359 /* Collect labels in this block. We don't keep those corresponding
8360 to END {IF|SELECT}, these are checked in resolve_branch by going
8361 up through the code_stack. */
8362 for (c
= block
; c
; c
= c
->next
)
8364 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8365 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8368 /* Merge with labels from parent block. */
8371 gcc_assert (cs_base
->prev
->reachable_labels
);
8372 bitmap_ior_into (cs_base
->reachable_labels
,
8373 cs_base
->prev
->reachable_labels
);
8379 resolve_lock_unlock (gfc_code
*code
)
8381 if (code
->expr1
->ts
.type
!= BT_DERIVED
8382 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8383 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8384 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8385 || code
->expr1
->rank
!= 0
8386 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8387 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8388 &code
->expr1
->where
);
8392 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8393 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8394 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8395 &code
->expr2
->where
);
8398 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8399 _("STAT variable")))
8404 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8405 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8406 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8407 &code
->expr3
->where
);
8410 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8411 _("ERRMSG variable")))
8414 /* Check ACQUIRED_LOCK. */
8416 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8417 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8418 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8419 "variable", &code
->expr4
->where
);
8422 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8423 _("ACQUIRED_LOCK variable")))
8429 resolve_sync (gfc_code
*code
)
8431 /* Check imageset. The * case matches expr1 == NULL. */
8434 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8435 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8436 "INTEGER expression", &code
->expr1
->where
);
8437 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8438 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8439 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8440 &code
->expr1
->where
);
8441 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8442 && gfc_simplify_expr (code
->expr1
, 0))
8444 gfc_constructor
*cons
;
8445 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8446 for (; cons
; cons
= gfc_constructor_next (cons
))
8447 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8448 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8449 gfc_error ("Imageset argument at %L must between 1 and "
8450 "num_images()", &cons
->expr
->where
);
8456 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8457 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8458 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8459 &code
->expr2
->where
);
8463 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8464 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8465 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8466 &code
->expr3
->where
);
8470 /* Given a branch to a label, see if the branch is conforming.
8471 The code node describes where the branch is located. */
8474 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8481 /* Step one: is this a valid branching target? */
8483 if (label
->defined
== ST_LABEL_UNKNOWN
)
8485 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8490 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8492 gfc_error ("Statement at %L is not a valid branch target statement "
8493 "for the branch statement at %L", &label
->where
, &code
->loc
);
8497 /* Step two: make sure this branch is not a branch to itself ;-) */
8499 if (code
->here
== label
)
8501 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8505 /* Step three: See if the label is in the same block as the
8506 branching statement. The hard work has been done by setting up
8507 the bitmap reachable_labels. */
8509 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8511 /* Check now whether there is a CRITICAL construct; if so, check
8512 whether the label is still visible outside of the CRITICAL block,
8513 which is invalid. */
8514 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8516 if (stack
->current
->op
== EXEC_CRITICAL
8517 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8518 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8519 "label at %L", &code
->loc
, &label
->where
);
8520 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8521 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8522 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8523 "for label at %L", &code
->loc
, &label
->where
);
8529 /* Step four: If we haven't found the label in the bitmap, it may
8530 still be the label of the END of the enclosing block, in which
8531 case we find it by going up the code_stack. */
8533 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8535 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8537 if (stack
->current
->op
== EXEC_CRITICAL
)
8539 /* Note: A label at END CRITICAL does not leave the CRITICAL
8540 construct as END CRITICAL is still part of it. */
8541 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8542 " at %L", &code
->loc
, &label
->where
);
8545 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8547 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8548 "label at %L", &code
->loc
, &label
->where
);
8555 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8559 /* The label is not in an enclosing block, so illegal. This was
8560 allowed in Fortran 66, so we allow it as extension. No
8561 further checks are necessary in this case. */
8562 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8563 "as the GOTO statement at %L", &label
->where
,
8569 /* Check whether EXPR1 has the same shape as EXPR2. */
8572 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8574 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8575 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8576 bool result
= false;
8579 /* Compare the rank. */
8580 if (expr1
->rank
!= expr2
->rank
)
8583 /* Compare the size of each dimension. */
8584 for (i
=0; i
<expr1
->rank
; i
++)
8586 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8589 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8592 if (mpz_cmp (shape
[i
], shape2
[i
]))
8596 /* When either of the two expression is an assumed size array, we
8597 ignore the comparison of dimension sizes. */
8602 gfc_clear_shape (shape
, i
);
8603 gfc_clear_shape (shape2
, i
);
8608 /* Check whether a WHERE assignment target or a WHERE mask expression
8609 has the same shape as the outmost WHERE mask expression. */
8612 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8618 cblock
= code
->block
;
8620 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8621 In case of nested WHERE, only the outmost one is stored. */
8622 if (mask
== NULL
) /* outmost WHERE */
8624 else /* inner WHERE */
8631 /* Check if the mask-expr has a consistent shape with the
8632 outmost WHERE mask-expr. */
8633 if (!resolve_where_shape (cblock
->expr1
, e
))
8634 gfc_error ("WHERE mask at %L has inconsistent shape",
8635 &cblock
->expr1
->where
);
8638 /* the assignment statement of a WHERE statement, or the first
8639 statement in where-body-construct of a WHERE construct */
8640 cnext
= cblock
->next
;
8645 /* WHERE assignment statement */
8648 /* Check shape consistent for WHERE assignment target. */
8649 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8650 gfc_error ("WHERE assignment target at %L has "
8651 "inconsistent shape", &cnext
->expr1
->where
);
8655 case EXEC_ASSIGN_CALL
:
8656 resolve_call (cnext
);
8657 if (!cnext
->resolved_sym
->attr
.elemental
)
8658 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8659 &cnext
->ext
.actual
->expr
->where
);
8662 /* WHERE or WHERE construct is part of a where-body-construct */
8664 resolve_where (cnext
, e
);
8668 gfc_error ("Unsupported statement inside WHERE at %L",
8671 /* the next statement within the same where-body-construct */
8672 cnext
= cnext
->next
;
8674 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8675 cblock
= cblock
->block
;
8680 /* Resolve assignment in FORALL construct.
8681 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8682 FORALL index variables. */
8685 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8689 for (n
= 0; n
< nvar
; n
++)
8691 gfc_symbol
*forall_index
;
8693 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8695 /* Check whether the assignment target is one of the FORALL index
8697 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8698 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8699 gfc_error ("Assignment to a FORALL index variable at %L",
8700 &code
->expr1
->where
);
8703 /* If one of the FORALL index variables doesn't appear in the
8704 assignment variable, then there could be a many-to-one
8705 assignment. Emit a warning rather than an error because the
8706 mask could be resolving this problem. */
8707 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8708 gfc_warning ("The FORALL with index '%s' is not used on the "
8709 "left side of the assignment at %L and so might "
8710 "cause multiple assignment to this object",
8711 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8717 /* Resolve WHERE statement in FORALL construct. */
8720 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8721 gfc_expr
**var_expr
)
8726 cblock
= code
->block
;
8729 /* the assignment statement of a WHERE statement, or the first
8730 statement in where-body-construct of a WHERE construct */
8731 cnext
= cblock
->next
;
8736 /* WHERE assignment statement */
8738 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8741 /* WHERE operator assignment statement */
8742 case EXEC_ASSIGN_CALL
:
8743 resolve_call (cnext
);
8744 if (!cnext
->resolved_sym
->attr
.elemental
)
8745 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8746 &cnext
->ext
.actual
->expr
->where
);
8749 /* WHERE or WHERE construct is part of a where-body-construct */
8751 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8755 gfc_error ("Unsupported statement inside WHERE at %L",
8758 /* the next statement within the same where-body-construct */
8759 cnext
= cnext
->next
;
8761 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8762 cblock
= cblock
->block
;
8767 /* Traverse the FORALL body to check whether the following errors exist:
8768 1. For assignment, check if a many-to-one assignment happens.
8769 2. For WHERE statement, check the WHERE body to see if there is any
8770 many-to-one assignment. */
8773 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8777 c
= code
->block
->next
;
8783 case EXEC_POINTER_ASSIGN
:
8784 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8787 case EXEC_ASSIGN_CALL
:
8791 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8792 there is no need to handle it here. */
8796 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8801 /* The next statement in the FORALL body. */
8807 /* Counts the number of iterators needed inside a forall construct, including
8808 nested forall constructs. This is used to allocate the needed memory
8809 in gfc_resolve_forall. */
8812 gfc_count_forall_iterators (gfc_code
*code
)
8814 int max_iters
, sub_iters
, current_iters
;
8815 gfc_forall_iterator
*fa
;
8817 gcc_assert(code
->op
== EXEC_FORALL
);
8821 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8824 code
= code
->block
->next
;
8828 if (code
->op
== EXEC_FORALL
)
8830 sub_iters
= gfc_count_forall_iterators (code
);
8831 if (sub_iters
> max_iters
)
8832 max_iters
= sub_iters
;
8837 return current_iters
+ max_iters
;
8841 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8842 gfc_resolve_forall_body to resolve the FORALL body. */
8845 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8847 static gfc_expr
**var_expr
;
8848 static int total_var
= 0;
8849 static int nvar
= 0;
8851 gfc_forall_iterator
*fa
;
8856 /* Start to resolve a FORALL construct */
8857 if (forall_save
== 0)
8859 /* Count the total number of FORALL index in the nested FORALL
8860 construct in order to allocate the VAR_EXPR with proper size. */
8861 total_var
= gfc_count_forall_iterators (code
);
8863 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8864 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8867 /* The information about FORALL iterator, including FORALL index start, end
8868 and stride. The FORALL index can not appear in start, end or stride. */
8869 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8871 /* Check if any outer FORALL index name is the same as the current
8873 for (i
= 0; i
< nvar
; i
++)
8875 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8877 gfc_error ("An outer FORALL construct already has an index "
8878 "with this name %L", &fa
->var
->where
);
8882 /* Record the current FORALL index. */
8883 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8887 /* No memory leak. */
8888 gcc_assert (nvar
<= total_var
);
8891 /* Resolve the FORALL body. */
8892 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8894 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8895 gfc_resolve_blocks (code
->block
, ns
);
8899 /* Free only the VAR_EXPRs allocated in this frame. */
8900 for (i
= nvar
; i
< tmp
; i
++)
8901 gfc_free_expr (var_expr
[i
]);
8905 /* We are in the outermost FORALL construct. */
8906 gcc_assert (forall_save
== 0);
8908 /* VAR_EXPR is not needed any more. */
8915 /* Resolve a BLOCK construct statement. */
8918 resolve_block_construct (gfc_code
* code
)
8920 /* Resolve the BLOCK's namespace. */
8921 gfc_resolve (code
->ext
.block
.ns
);
8923 /* For an ASSOCIATE block, the associations (and their targets) are already
8924 resolved during resolve_symbol. */
8928 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8931 static void resolve_code (gfc_code
*, gfc_namespace
*);
8934 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8938 for (; b
; b
= b
->block
)
8940 t
= gfc_resolve_expr (b
->expr1
);
8941 if (!gfc_resolve_expr (b
->expr2
))
8947 if (t
&& b
->expr1
!= NULL
8948 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8949 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8956 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8957 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8962 resolve_branch (b
->label1
, b
);
8966 resolve_block_construct (b
);
8970 case EXEC_SELECT_TYPE
:
8974 case EXEC_DO_CONCURRENT
:
8982 case EXEC_OMP_ATOMIC
:
8983 case EXEC_OMP_CRITICAL
:
8985 case EXEC_OMP_MASTER
:
8986 case EXEC_OMP_ORDERED
:
8987 case EXEC_OMP_PARALLEL
:
8988 case EXEC_OMP_PARALLEL_DO
:
8989 case EXEC_OMP_PARALLEL_SECTIONS
:
8990 case EXEC_OMP_PARALLEL_WORKSHARE
:
8991 case EXEC_OMP_SECTIONS
:
8992 case EXEC_OMP_SINGLE
:
8994 case EXEC_OMP_TASKWAIT
:
8995 case EXEC_OMP_TASKYIELD
:
8996 case EXEC_OMP_WORKSHARE
:
9000 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9003 resolve_code (b
->next
, ns
);
9008 /* Does everything to resolve an ordinary assignment. Returns true
9009 if this is an interface assignment. */
9011 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9020 symbol_attribute attr
;
9022 if (gfc_extend_assign (code
, ns
))
9026 if (code
->op
== EXEC_ASSIGN_CALL
)
9028 lhs
= code
->ext
.actual
->expr
;
9029 rhsptr
= &code
->ext
.actual
->next
->expr
;
9033 gfc_actual_arglist
* args
;
9034 gfc_typebound_proc
* tbp
;
9036 gcc_assert (code
->op
== EXEC_COMPCALL
);
9038 args
= code
->expr1
->value
.compcall
.actual
;
9040 rhsptr
= &args
->next
->expr
;
9042 tbp
= code
->expr1
->value
.compcall
.tbp
;
9043 gcc_assert (!tbp
->is_generic
);
9046 /* Make a temporary rhs when there is a default initializer
9047 and rhs is the same symbol as the lhs. */
9048 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9049 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9050 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9051 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9052 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9061 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9062 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9066 /* Handle the case of a BOZ literal on the RHS. */
9067 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9070 if (gfc_option
.warn_surprising
)
9071 gfc_warning ("BOZ literal at %L is bitwise transferred "
9072 "non-integer symbol '%s'", &code
->loc
,
9073 lhs
->symtree
->n
.sym
->name
);
9075 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9077 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9079 if (rc
== ARITH_UNDERFLOW
)
9080 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9081 ". This check can be disabled with the option "
9082 "-fno-range-check", &rhs
->where
);
9083 else if (rc
== ARITH_OVERFLOW
)
9084 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9085 ". This check can be disabled with the option "
9086 "-fno-range-check", &rhs
->where
);
9087 else if (rc
== ARITH_NAN
)
9088 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9089 ". This check can be disabled with the option "
9090 "-fno-range-check", &rhs
->where
);
9095 if (lhs
->ts
.type
== BT_CHARACTER
9096 && gfc_option
.warn_character_truncation
)
9098 if (lhs
->ts
.u
.cl
!= NULL
9099 && lhs
->ts
.u
.cl
->length
!= NULL
9100 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9101 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9103 if (rhs
->expr_type
== EXPR_CONSTANT
)
9104 rlen
= rhs
->value
.character
.length
;
9106 else if (rhs
->ts
.u
.cl
!= NULL
9107 && rhs
->ts
.u
.cl
->length
!= NULL
9108 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9109 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9111 if (rlen
&& llen
&& rlen
> llen
)
9112 gfc_warning_now ("CHARACTER expression will be truncated "
9113 "in assignment (%d/%d) at %L",
9114 llen
, rlen
, &code
->loc
);
9117 /* Ensure that a vector index expression for the lvalue is evaluated
9118 to a temporary if the lvalue symbol is referenced in it. */
9121 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9122 if (ref
->type
== REF_ARRAY
)
9124 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9125 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9126 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9127 ref
->u
.ar
.start
[n
]))
9129 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9133 if (gfc_pure (NULL
))
9135 if (lhs
->ts
.type
== BT_DERIVED
9136 && lhs
->expr_type
== EXPR_VARIABLE
9137 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9138 && rhs
->expr_type
== EXPR_VARIABLE
9139 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9140 || gfc_is_coindexed (rhs
)))
9143 if (gfc_is_coindexed (rhs
))
9144 gfc_error ("Coindexed expression at %L is assigned to "
9145 "a derived type variable with a POINTER "
9146 "component in a PURE procedure",
9149 gfc_error ("The impure variable at %L is assigned to "
9150 "a derived type variable with a POINTER "
9151 "component in a PURE procedure (12.6)",
9156 /* Fortran 2008, C1283. */
9157 if (gfc_is_coindexed (lhs
))
9159 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9160 "procedure", &rhs
->where
);
9165 if (gfc_implicit_pure (NULL
))
9167 if (lhs
->expr_type
== EXPR_VARIABLE
9168 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9169 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9170 gfc_unset_implicit_pure (NULL
);
9172 if (lhs
->ts
.type
== BT_DERIVED
9173 && lhs
->expr_type
== EXPR_VARIABLE
9174 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9175 && rhs
->expr_type
== EXPR_VARIABLE
9176 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9177 || gfc_is_coindexed (rhs
)))
9178 gfc_unset_implicit_pure (NULL
);
9180 /* Fortran 2008, C1283. */
9181 if (gfc_is_coindexed (lhs
))
9182 gfc_unset_implicit_pure (NULL
);
9185 /* F2008, 7.2.1.2. */
9186 attr
= gfc_expr_attr (lhs
);
9187 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9189 if (attr
.codimension
)
9191 gfc_error ("Assignment to polymorphic coarray at %L is not "
9192 "permitted", &lhs
->where
);
9195 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9196 "polymorphic variable at %L", &lhs
->where
))
9198 if (!gfc_option
.flag_realloc_lhs
)
9200 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9201 "requires -frealloc-lhs", &lhs
->where
);
9205 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9206 "is not yet supported", &lhs
->where
);
9209 else if (lhs
->ts
.type
== BT_CLASS
)
9211 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9212 "assignment at %L - check that there is a matching specific "
9213 "subroutine for '=' operator", &lhs
->where
);
9217 /* F2008, Section 7.2.1.2. */
9218 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9220 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9221 "component in assignment at %L", &lhs
->where
);
9225 gfc_check_assign (lhs
, rhs
, 1);
9230 /* Add a component reference onto an expression. */
9233 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9238 ref
= &((*ref
)->next
);
9239 *ref
= gfc_get_ref ();
9240 (*ref
)->type
= REF_COMPONENT
;
9241 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9242 (*ref
)->u
.c
.component
= c
;
9245 /* Add a full array ref, as necessary. */
9248 gfc_add_full_array_ref (e
, c
->as
);
9249 e
->rank
= c
->as
->rank
;
9254 /* Build an assignment. Keep the argument 'op' for future use, so that
9255 pointer assignments can be made. */
9258 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9259 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9261 gfc_code
*this_code
;
9263 this_code
= gfc_get_code (op
);
9264 this_code
->next
= NULL
;
9265 this_code
->expr1
= gfc_copy_expr (expr1
);
9266 this_code
->expr2
= gfc_copy_expr (expr2
);
9267 this_code
->loc
= loc
;
9270 add_comp_ref (this_code
->expr1
, comp1
);
9271 add_comp_ref (this_code
->expr2
, comp2
);
9278 /* Makes a temporary variable expression based on the characteristics of
9279 a given variable expression. */
9282 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9284 static int serial
= 0;
9285 char name
[GFC_MAX_SYMBOL_LEN
];
9288 gfc_array_ref
*aref
;
9291 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9292 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9293 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9299 /* This function could be expanded to support other expression type
9300 but this is not needed here. */
9301 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9303 /* Obtain the arrayspec for the temporary. */
9306 aref
= gfc_find_array_ref (e
);
9307 if (e
->expr_type
== EXPR_VARIABLE
9308 && e
->symtree
->n
.sym
->as
== aref
->as
)
9312 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9313 if (ref
->type
== REF_COMPONENT
9314 && ref
->u
.c
.component
->as
== aref
->as
)
9322 /* Add the attributes and the arrayspec to the temporary. */
9323 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9324 tmp
->n
.sym
->attr
.function
= 0;
9325 tmp
->n
.sym
->attr
.result
= 0;
9326 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9330 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9333 if (as
->type
== AS_DEFERRED
)
9334 tmp
->n
.sym
->attr
.allocatable
= 1;
9337 tmp
->n
.sym
->attr
.dimension
= 0;
9339 gfc_set_sym_referenced (tmp
->n
.sym
);
9340 gfc_commit_symbol (tmp
->n
.sym
);
9341 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9343 /* Should the lhs be a section, use its array ref for the
9344 temporary expression. */
9345 if (aref
&& aref
->type
!= AR_FULL
)
9347 gfc_free_ref_list (e
->ref
);
9348 e
->ref
= gfc_copy_ref (ref
);
9354 /* Add one line of code to the code chain, making sure that 'head' and
9355 'tail' are appropriately updated. */
9358 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9360 gcc_assert (this_code
);
9362 *head
= *tail
= *this_code
;
9364 *tail
= gfc_append_code (*tail
, *this_code
);
9369 /* Counts the potential number of part array references that would
9370 result from resolution of typebound defined assignments. */
9373 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9376 int c_depth
= 0, t_depth
;
9378 for (c
= derived
->components
; c
; c
= c
->next
)
9380 if ((c
->ts
.type
!= BT_DERIVED
9382 || c
->attr
.allocatable
9383 || c
->attr
.proc_pointer_comp
9384 || c
->attr
.class_pointer
9385 || c
->attr
.proc_pointer
)
9386 && !c
->attr
.defined_assign_comp
)
9389 if (c
->as
&& c_depth
== 0)
9392 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9393 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9398 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9400 return depth
+ c_depth
;
9404 /* Implement 7.2.1.3 of the F08 standard:
9405 "An intrinsic assignment where the variable is of derived type is
9406 performed as if each component of the variable were assigned from the
9407 corresponding component of expr using pointer assignment (7.2.2) for
9408 each pointer component, defined assignment for each nonpointer
9409 nonallocatable component of a type that has a type-bound defined
9410 assignment consistent with the component, intrinsic assignment for
9411 each other nonpointer nonallocatable component, ..."
9413 The pointer assignments are taken care of by the intrinsic
9414 assignment of the structure itself. This function recursively adds
9415 defined assignments where required. The recursion is accomplished
9416 by calling resolve_code.
9418 When the lhs in a defined assignment has intent INOUT, we need a
9419 temporary for the lhs. In pseudo-code:
9421 ! Only call function lhs once.
9422 if (lhs is not a constant or an variable)
9425 ! Do the intrinsic assignment
9427 ! Now do the defined assignments
9428 do over components with typebound defined assignment [%cmp]
9429 #if one component's assignment procedure is INOUT
9431 #if expr2 non-variable
9437 t1%cmp {defined=} expr2%cmp
9443 expr1%cmp {defined=} expr2%cmp
9447 /* The temporary assignments have to be put on top of the additional
9448 code to avoid the result being changed by the intrinsic assignment.
9450 static int component_assignment_level
= 0;
9451 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9454 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9456 gfc_component
*comp1
, *comp2
;
9457 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9459 int error_count
, depth
;
9461 gfc_get_errors (NULL
, &error_count
);
9463 /* Filter out continuing processing after an error. */
9465 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9466 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9469 /* TODO: Handle more than one part array reference in assignments. */
9470 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9471 (*code
)->expr1
->rank
? 1 : 0);
9474 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9475 "done because multiple part array references would "
9476 "occur in intermediate expressions.", &(*code
)->loc
);
9480 component_assignment_level
++;
9482 /* Create a temporary so that functions get called only once. */
9483 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9484 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9488 /* Assign the rhs to the temporary. */
9489 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9490 this_code
= build_assignment (EXEC_ASSIGN
,
9491 tmp_expr
, (*code
)->expr2
,
9492 NULL
, NULL
, (*code
)->loc
);
9493 /* Add the code and substitute the rhs expression. */
9494 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9495 gfc_free_expr ((*code
)->expr2
);
9496 (*code
)->expr2
= tmp_expr
;
9499 /* Do the intrinsic assignment. This is not needed if the lhs is one
9500 of the temporaries generated here, since the intrinsic assignment
9501 to the final result already does this. */
9502 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9504 this_code
= build_assignment (EXEC_ASSIGN
,
9505 (*code
)->expr1
, (*code
)->expr2
,
9506 NULL
, NULL
, (*code
)->loc
);
9507 add_code_to_chain (&this_code
, &head
, &tail
);
9510 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9511 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9514 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9518 /* The intrinsic assignment does the right thing for pointers
9519 of all kinds and allocatable components. */
9520 if (comp1
->ts
.type
!= BT_DERIVED
9521 || comp1
->attr
.pointer
9522 || comp1
->attr
.allocatable
9523 || comp1
->attr
.proc_pointer_comp
9524 || comp1
->attr
.class_pointer
9525 || comp1
->attr
.proc_pointer
)
9528 /* Make an assigment for this component. */
9529 this_code
= build_assignment (EXEC_ASSIGN
,
9530 (*code
)->expr1
, (*code
)->expr2
,
9531 comp1
, comp2
, (*code
)->loc
);
9533 /* Convert the assignment if there is a defined assignment for
9534 this type. Otherwise, using the call from resolve_code,
9535 recurse into its components. */
9536 resolve_code (this_code
, ns
);
9538 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9540 gfc_formal_arglist
*dummy_args
;
9542 /* Check that there is a typebound defined assignment. If not,
9543 then this must be a module defined assignment. We cannot
9544 use the defined_assign_comp attribute here because it must
9545 be this derived type that has the defined assignment and not
9547 if (!(comp1
->ts
.u
.derived
->f2k_derived
9548 && comp1
->ts
.u
.derived
->f2k_derived
9549 ->tb_op
[INTRINSIC_ASSIGN
]))
9551 gfc_free_statements (this_code
);
9556 /* If the first argument of the subroutine has intent INOUT
9557 a temporary must be generated and used instead. */
9558 rsym
= this_code
->resolved_sym
;
9559 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9561 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9563 gfc_code
*temp_code
;
9566 /* Build the temporary required for the assignment and put
9567 it at the head of the generated code. */
9570 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9571 temp_code
= build_assignment (EXEC_ASSIGN
,
9573 NULL
, NULL
, (*code
)->loc
);
9575 /* For allocatable LHS, check whether it is allocated. Note
9576 that allocatable components with defined assignment are
9577 not yet support. See PR 57696. */
9578 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9582 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9583 block
= gfc_get_code (EXEC_IF
);
9584 block
->block
= gfc_get_code (EXEC_IF
);
9586 = gfc_build_intrinsic_call (ns
,
9587 GFC_ISYM_ALLOCATED
, "allocated",
9588 (*code
)->loc
, 1, e
);
9589 block
->block
->next
= temp_code
;
9592 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9595 /* Replace the first actual arg with the component of the
9597 gfc_free_expr (this_code
->ext
.actual
->expr
);
9598 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9599 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9601 /* If the LHS variable is allocatable and wasn't allocated and
9602 the temporary is allocatable, pointer assign the address of
9603 the freshly allocated LHS to the temporary. */
9604 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9605 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9610 cond
= gfc_get_expr ();
9611 cond
->ts
.type
= BT_LOGICAL
;
9612 cond
->ts
.kind
= gfc_default_logical_kind
;
9613 cond
->expr_type
= EXPR_OP
;
9614 cond
->where
= (*code
)->loc
;
9615 cond
->value
.op
.op
= INTRINSIC_NOT
;
9616 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9617 GFC_ISYM_ALLOCATED
, "allocated",
9618 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9619 block
= gfc_get_code (EXEC_IF
);
9620 block
->block
= gfc_get_code (EXEC_IF
);
9621 block
->block
->expr1
= cond
;
9622 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9624 NULL
, NULL
, (*code
)->loc
);
9625 add_code_to_chain (&block
, &head
, &tail
);
9629 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9631 /* Don't add intrinsic assignments since they are already
9632 effected by the intrinsic assignment of the structure. */
9633 gfc_free_statements (this_code
);
9638 add_code_to_chain (&this_code
, &head
, &tail
);
9642 /* Transfer the value to the final result. */
9643 this_code
= build_assignment (EXEC_ASSIGN
,
9645 comp1
, comp2
, (*code
)->loc
);
9646 add_code_to_chain (&this_code
, &head
, &tail
);
9650 /* Put the temporary assignments at the top of the generated code. */
9651 if (tmp_head
&& component_assignment_level
== 1)
9653 gfc_append_code (tmp_head
, head
);
9655 tmp_head
= tmp_tail
= NULL
;
9658 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9659 // not accidentally deallocated. Hence, nullify t1.
9660 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9661 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9667 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9668 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9669 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9670 block
= gfc_get_code (EXEC_IF
);
9671 block
->block
= gfc_get_code (EXEC_IF
);
9672 block
->block
->expr1
= cond
;
9673 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9674 t1
, gfc_get_null_expr (&(*code
)->loc
),
9675 NULL
, NULL
, (*code
)->loc
);
9676 gfc_append_code (tail
, block
);
9680 /* Now attach the remaining code chain to the input code. Step on
9681 to the end of the new code since resolution is complete. */
9682 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9683 tail
->next
= (*code
)->next
;
9684 /* Overwrite 'code' because this would place the intrinsic assignment
9685 before the temporary for the lhs is created. */
9686 gfc_free_expr ((*code
)->expr1
);
9687 gfc_free_expr ((*code
)->expr2
);
9693 component_assignment_level
--;
9697 /* Given a block of code, recursively resolve everything pointed to by this
9701 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9703 int omp_workshare_save
;
9704 int forall_save
, do_concurrent_save
;
9708 frame
.prev
= cs_base
;
9712 find_reachable_labels (code
);
9714 for (; code
; code
= code
->next
)
9716 frame
.current
= code
;
9717 forall_save
= forall_flag
;
9718 do_concurrent_save
= gfc_do_concurrent_flag
;
9720 if (code
->op
== EXEC_FORALL
)
9723 gfc_resolve_forall (code
, ns
, forall_save
);
9726 else if (code
->block
)
9728 omp_workshare_save
= -1;
9731 case EXEC_OMP_PARALLEL_WORKSHARE
:
9732 omp_workshare_save
= omp_workshare_flag
;
9733 omp_workshare_flag
= 1;
9734 gfc_resolve_omp_parallel_blocks (code
, ns
);
9736 case EXEC_OMP_PARALLEL
:
9737 case EXEC_OMP_PARALLEL_DO
:
9738 case EXEC_OMP_PARALLEL_SECTIONS
:
9740 omp_workshare_save
= omp_workshare_flag
;
9741 omp_workshare_flag
= 0;
9742 gfc_resolve_omp_parallel_blocks (code
, ns
);
9745 gfc_resolve_omp_do_blocks (code
, ns
);
9747 case EXEC_SELECT_TYPE
:
9748 /* Blocks are handled in resolve_select_type because we have
9749 to transform the SELECT TYPE into ASSOCIATE first. */
9751 case EXEC_DO_CONCURRENT
:
9752 gfc_do_concurrent_flag
= 1;
9753 gfc_resolve_blocks (code
->block
, ns
);
9754 gfc_do_concurrent_flag
= 2;
9756 case EXEC_OMP_WORKSHARE
:
9757 omp_workshare_save
= omp_workshare_flag
;
9758 omp_workshare_flag
= 1;
9761 gfc_resolve_blocks (code
->block
, ns
);
9765 if (omp_workshare_save
!= -1)
9766 omp_workshare_flag
= omp_workshare_save
;
9770 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9771 t
= gfc_resolve_expr (code
->expr1
);
9772 forall_flag
= forall_save
;
9773 gfc_do_concurrent_flag
= do_concurrent_save
;
9775 if (!gfc_resolve_expr (code
->expr2
))
9778 if (code
->op
== EXEC_ALLOCATE
9779 && !gfc_resolve_expr (code
->expr3
))
9785 case EXEC_END_BLOCK
:
9786 case EXEC_END_NESTED_BLOCK
:
9790 case EXEC_ERROR_STOP
:
9794 case EXEC_ASSIGN_CALL
:
9799 case EXEC_SYNC_IMAGES
:
9800 case EXEC_SYNC_MEMORY
:
9801 resolve_sync (code
);
9806 resolve_lock_unlock (code
);
9810 /* Keep track of which entry we are up to. */
9811 current_entry_id
= code
->ext
.entry
->id
;
9815 resolve_where (code
, NULL
);
9819 if (code
->expr1
!= NULL
)
9821 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9822 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9823 "INTEGER variable", &code
->expr1
->where
);
9824 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9825 gfc_error ("Variable '%s' has not been assigned a target "
9826 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9827 &code
->expr1
->where
);
9830 resolve_branch (code
->label1
, code
);
9834 if (code
->expr1
!= NULL
9835 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9836 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9837 "INTEGER return specifier", &code
->expr1
->where
);
9840 case EXEC_INIT_ASSIGN
:
9841 case EXEC_END_PROCEDURE
:
9848 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
9852 if (resolve_ordinary_assign (code
, ns
))
9854 if (code
->op
== EXEC_COMPCALL
)
9860 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
9861 if (code
->expr1
->ts
.type
== BT_DERIVED
9862 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
9863 generate_component_assignments (&code
, ns
);
9867 case EXEC_LABEL_ASSIGN
:
9868 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9869 gfc_error ("Label %d referenced at %L is never defined",
9870 code
->label1
->value
, &code
->label1
->where
);
9872 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9873 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9874 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9875 != gfc_default_integer_kind
9876 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9877 gfc_error ("ASSIGN statement at %L requires a scalar "
9878 "default INTEGER variable", &code
->expr1
->where
);
9881 case EXEC_POINTER_ASSIGN
:
9888 /* This is both a variable definition and pointer assignment
9889 context, so check both of them. For rank remapping, a final
9890 array ref may be present on the LHS and fool gfc_expr_attr
9891 used in gfc_check_vardef_context. Remove it. */
9892 e
= remove_last_array_ref (code
->expr1
);
9893 t
= gfc_check_vardef_context (e
, true, false, false,
9894 _("pointer assignment"));
9896 t
= gfc_check_vardef_context (e
, false, false, false,
9897 _("pointer assignment"));
9902 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9906 case EXEC_ARITHMETIC_IF
:
9908 && code
->expr1
->ts
.type
!= BT_INTEGER
9909 && code
->expr1
->ts
.type
!= BT_REAL
)
9910 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9911 "expression", &code
->expr1
->where
);
9913 resolve_branch (code
->label1
, code
);
9914 resolve_branch (code
->label2
, code
);
9915 resolve_branch (code
->label3
, code
);
9919 if (t
&& code
->expr1
!= NULL
9920 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9921 || code
->expr1
->rank
!= 0))
9922 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9923 &code
->expr1
->where
);
9928 resolve_call (code
);
9933 resolve_typebound_subroutine (code
);
9937 resolve_ppc_call (code
);
9941 /* Select is complicated. Also, a SELECT construct could be
9942 a transformed computed GOTO. */
9943 resolve_select (code
, false);
9946 case EXEC_SELECT_TYPE
:
9947 resolve_select_type (code
, ns
);
9951 resolve_block_construct (code
);
9955 if (code
->ext
.iterator
!= NULL
)
9957 gfc_iterator
*iter
= code
->ext
.iterator
;
9958 if (gfc_resolve_iterator (iter
, true, false))
9959 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9964 if (code
->expr1
== NULL
)
9965 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9967 && (code
->expr1
->rank
!= 0
9968 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9969 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9970 "a scalar LOGICAL expression", &code
->expr1
->where
);
9975 resolve_allocate_deallocate (code
, "ALLOCATE");
9979 case EXEC_DEALLOCATE
:
9981 resolve_allocate_deallocate (code
, "DEALLOCATE");
9986 if (!gfc_resolve_open (code
->ext
.open
))
9989 resolve_branch (code
->ext
.open
->err
, code
);
9993 if (!gfc_resolve_close (code
->ext
.close
))
9996 resolve_branch (code
->ext
.close
->err
, code
);
9999 case EXEC_BACKSPACE
:
10003 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10006 resolve_branch (code
->ext
.filepos
->err
, code
);
10010 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10013 resolve_branch (code
->ext
.inquire
->err
, code
);
10016 case EXEC_IOLENGTH
:
10017 gcc_assert (code
->ext
.inquire
!= NULL
);
10018 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10021 resolve_branch (code
->ext
.inquire
->err
, code
);
10025 if (!gfc_resolve_wait (code
->ext
.wait
))
10028 resolve_branch (code
->ext
.wait
->err
, code
);
10029 resolve_branch (code
->ext
.wait
->end
, code
);
10030 resolve_branch (code
->ext
.wait
->eor
, code
);
10035 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10038 resolve_branch (code
->ext
.dt
->err
, code
);
10039 resolve_branch (code
->ext
.dt
->end
, code
);
10040 resolve_branch (code
->ext
.dt
->eor
, code
);
10043 case EXEC_TRANSFER
:
10044 resolve_transfer (code
);
10047 case EXEC_DO_CONCURRENT
:
10049 resolve_forall_iterators (code
->ext
.forall_iterator
);
10051 if (code
->expr1
!= NULL
10052 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10053 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10054 "expression", &code
->expr1
->where
);
10057 case EXEC_OMP_ATOMIC
:
10058 case EXEC_OMP_BARRIER
:
10059 case EXEC_OMP_CRITICAL
:
10060 case EXEC_OMP_FLUSH
:
10062 case EXEC_OMP_MASTER
:
10063 case EXEC_OMP_ORDERED
:
10064 case EXEC_OMP_SECTIONS
:
10065 case EXEC_OMP_SINGLE
:
10066 case EXEC_OMP_TASKWAIT
:
10067 case EXEC_OMP_TASKYIELD
:
10068 case EXEC_OMP_WORKSHARE
:
10069 gfc_resolve_omp_directive (code
, ns
);
10072 case EXEC_OMP_PARALLEL
:
10073 case EXEC_OMP_PARALLEL_DO
:
10074 case EXEC_OMP_PARALLEL_SECTIONS
:
10075 case EXEC_OMP_PARALLEL_WORKSHARE
:
10076 case EXEC_OMP_TASK
:
10077 omp_workshare_save
= omp_workshare_flag
;
10078 omp_workshare_flag
= 0;
10079 gfc_resolve_omp_directive (code
, ns
);
10080 omp_workshare_flag
= omp_workshare_save
;
10084 gfc_internal_error ("resolve_code(): Bad statement code");
10088 cs_base
= frame
.prev
;
10092 /* Resolve initial values and make sure they are compatible with
10096 resolve_values (gfc_symbol
*sym
)
10100 if (sym
->value
== NULL
)
10103 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10104 t
= resolve_structure_cons (sym
->value
, 1);
10106 t
= gfc_resolve_expr (sym
->value
);
10111 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10115 /* Verify any BIND(C) derived types in the namespace so we can report errors
10116 for them once, rather than for each variable declared of that type. */
10119 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10121 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10122 && derived_sym
->attr
.is_bind_c
== 1)
10123 verify_bind_c_derived_type (derived_sym
);
10129 /* Verify that any binding labels used in a given namespace do not collide
10130 with the names or binding labels of any global symbols. Multiple INTERFACE
10131 for the same procedure are permitted. */
10134 gfc_verify_binding_labels (gfc_symbol
*sym
)
10137 const char *module
;
10139 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10140 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10143 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10146 module
= sym
->module
;
10147 else if (sym
->ns
&& sym
->ns
->proc_name
10148 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10149 module
= sym
->ns
->proc_name
->name
;
10150 else if (sym
->ns
&& sym
->ns
->parent
10151 && sym
->ns
&& sym
->ns
->parent
->proc_name
10152 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10153 module
= sym
->ns
->parent
->proc_name
->name
;
10159 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10162 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10163 gsym
->where
= sym
->declared_at
;
10164 gsym
->sym_name
= sym
->name
;
10165 gsym
->binding_label
= sym
->binding_label
;
10166 gsym
->ns
= sym
->ns
;
10167 gsym
->mod_name
= module
;
10168 if (sym
->attr
.function
)
10169 gsym
->type
= GSYM_FUNCTION
;
10170 else if (sym
->attr
.subroutine
)
10171 gsym
->type
= GSYM_SUBROUTINE
;
10172 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10173 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10177 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10179 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10180 "identifier as entity at %L", sym
->name
,
10181 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10182 /* Clear the binding label to prevent checking multiple times. */
10183 sym
->binding_label
= NULL
;
10186 else if (sym
->attr
.flavor
== FL_VARIABLE
10187 && (strcmp (module
, gsym
->mod_name
) != 0
10188 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10190 /* This can only happen if the variable is defined in a module - if it
10191 isn't the same module, reject it. */
10192 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10193 "the same global identifier as entity at %L from module %s",
10194 sym
->name
, module
, sym
->binding_label
,
10195 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10196 sym
->binding_label
= NULL
;
10198 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10199 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10200 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10201 && sym
!= gsym
->ns
->proc_name
10202 && (module
!= gsym
->mod_name
10203 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10204 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10206 /* Print an error if the procedure is defined multiple times; we have to
10207 exclude references to the same procedure via module association or
10208 multiple checks for the same procedure. */
10209 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10210 "global identifier as entity at %L", sym
->name
,
10211 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10212 sym
->binding_label
= NULL
;
10217 /* Resolve an index expression. */
10220 resolve_index_expr (gfc_expr
*e
)
10222 if (!gfc_resolve_expr (e
))
10225 if (!gfc_simplify_expr (e
, 0))
10228 if (!gfc_specification_expr (e
))
10235 /* Resolve a charlen structure. */
10238 resolve_charlen (gfc_charlen
*cl
)
10241 bool saved_specification_expr
;
10247 saved_specification_expr
= specification_expr
;
10248 specification_expr
= true;
10250 if (cl
->length_from_typespec
)
10252 if (!gfc_resolve_expr (cl
->length
))
10254 specification_expr
= saved_specification_expr
;
10258 if (!gfc_simplify_expr (cl
->length
, 0))
10260 specification_expr
= saved_specification_expr
;
10267 if (!resolve_index_expr (cl
->length
))
10269 specification_expr
= saved_specification_expr
;
10274 /* "If the character length parameter value evaluates to a negative
10275 value, the length of character entities declared is zero." */
10276 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10278 if (gfc_option
.warn_surprising
)
10279 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10280 " the length has been set to zero",
10281 &cl
->length
->where
, i
);
10282 gfc_replace_expr (cl
->length
,
10283 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10286 /* Check that the character length is not too large. */
10287 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10288 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10289 && cl
->length
->ts
.type
== BT_INTEGER
10290 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10292 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10293 specification_expr
= saved_specification_expr
;
10297 specification_expr
= saved_specification_expr
;
10302 /* Test for non-constant shape arrays. */
10305 is_non_constant_shape_array (gfc_symbol
*sym
)
10311 not_constant
= false;
10312 if (sym
->as
!= NULL
)
10314 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10315 has not been simplified; parameter array references. Do the
10316 simplification now. */
10317 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10319 e
= sym
->as
->lower
[i
];
10320 if (e
&& (!resolve_index_expr(e
)
10321 || !gfc_is_constant_expr (e
)))
10322 not_constant
= true;
10323 e
= sym
->as
->upper
[i
];
10324 if (e
&& (!resolve_index_expr(e
)
10325 || !gfc_is_constant_expr (e
)))
10326 not_constant
= true;
10329 return not_constant
;
10332 /* Given a symbol and an initialization expression, add code to initialize
10333 the symbol to the function entry. */
10335 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10339 gfc_namespace
*ns
= sym
->ns
;
10341 /* Search for the function namespace if this is a contained
10342 function without an explicit result. */
10343 if (sym
->attr
.function
&& sym
== sym
->result
10344 && sym
->name
!= sym
->ns
->proc_name
->name
)
10346 ns
= ns
->contained
;
10347 for (;ns
; ns
= ns
->sibling
)
10348 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10354 gfc_free_expr (init
);
10358 /* Build an l-value expression for the result. */
10359 lval
= gfc_lval_expr_from_sym (sym
);
10361 /* Add the code at scope entry. */
10362 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10363 init_st
->next
= ns
->code
;
10364 ns
->code
= init_st
;
10366 /* Assign the default initializer to the l-value. */
10367 init_st
->loc
= sym
->declared_at
;
10368 init_st
->expr1
= lval
;
10369 init_st
->expr2
= init
;
10372 /* Assign the default initializer to a derived type variable or result. */
10375 apply_default_init (gfc_symbol
*sym
)
10377 gfc_expr
*init
= NULL
;
10379 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10382 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10383 init
= gfc_default_initializer (&sym
->ts
);
10385 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10388 build_init_assign (sym
, init
);
10389 sym
->attr
.referenced
= 1;
10392 /* Build an initializer for a local integer, real, complex, logical, or
10393 character variable, based on the command line flags finit-local-zero,
10394 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10395 null if the symbol should not have a default initialization. */
10397 build_default_init_expr (gfc_symbol
*sym
)
10400 gfc_expr
*init_expr
;
10403 /* These symbols should never have a default initialization. */
10404 if (sym
->attr
.allocatable
10405 || sym
->attr
.external
10407 || sym
->attr
.pointer
10408 || sym
->attr
.in_equivalence
10409 || sym
->attr
.in_common
10412 || sym
->attr
.cray_pointee
10413 || sym
->attr
.cray_pointer
10417 /* Now we'll try to build an initializer expression. */
10418 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10419 &sym
->declared_at
);
10421 /* We will only initialize integers, reals, complex, logicals, and
10422 characters, and only if the corresponding command-line flags
10423 were set. Otherwise, we free init_expr and return null. */
10424 switch (sym
->ts
.type
)
10427 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10428 mpz_set_si (init_expr
->value
.integer
,
10429 gfc_option
.flag_init_integer_value
);
10432 gfc_free_expr (init_expr
);
10438 switch (gfc_option
.flag_init_real
)
10440 case GFC_INIT_REAL_SNAN
:
10441 init_expr
->is_snan
= 1;
10442 /* Fall through. */
10443 case GFC_INIT_REAL_NAN
:
10444 mpfr_set_nan (init_expr
->value
.real
);
10447 case GFC_INIT_REAL_INF
:
10448 mpfr_set_inf (init_expr
->value
.real
, 1);
10451 case GFC_INIT_REAL_NEG_INF
:
10452 mpfr_set_inf (init_expr
->value
.real
, -1);
10455 case GFC_INIT_REAL_ZERO
:
10456 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10460 gfc_free_expr (init_expr
);
10467 switch (gfc_option
.flag_init_real
)
10469 case GFC_INIT_REAL_SNAN
:
10470 init_expr
->is_snan
= 1;
10471 /* Fall through. */
10472 case GFC_INIT_REAL_NAN
:
10473 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10474 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10477 case GFC_INIT_REAL_INF
:
10478 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10479 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10482 case GFC_INIT_REAL_NEG_INF
:
10483 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10484 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10487 case GFC_INIT_REAL_ZERO
:
10488 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10492 gfc_free_expr (init_expr
);
10499 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10500 init_expr
->value
.logical
= 0;
10501 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10502 init_expr
->value
.logical
= 1;
10505 gfc_free_expr (init_expr
);
10511 /* For characters, the length must be constant in order to
10512 create a default initializer. */
10513 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10514 && sym
->ts
.u
.cl
->length
10515 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10517 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10518 init_expr
->value
.character
.length
= char_len
;
10519 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10520 for (i
= 0; i
< char_len
; i
++)
10521 init_expr
->value
.character
.string
[i
]
10522 = (unsigned char) gfc_option
.flag_init_character_value
;
10526 gfc_free_expr (init_expr
);
10529 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10530 && sym
->ts
.u
.cl
->length
&& gfc_option
.flag_max_stack_var_size
!= 0)
10532 gfc_actual_arglist
*arg
;
10533 init_expr
= gfc_get_expr ();
10534 init_expr
->where
= sym
->declared_at
;
10535 init_expr
->ts
= sym
->ts
;
10536 init_expr
->expr_type
= EXPR_FUNCTION
;
10537 init_expr
->value
.function
.isym
=
10538 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10539 init_expr
->value
.function
.name
= "repeat";
10540 arg
= gfc_get_actual_arglist ();
10541 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10543 arg
->expr
->value
.character
.string
[0]
10544 = gfc_option
.flag_init_character_value
;
10545 arg
->next
= gfc_get_actual_arglist ();
10546 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10547 init_expr
->value
.function
.actual
= arg
;
10552 gfc_free_expr (init_expr
);
10558 /* Add an initialization expression to a local variable. */
10560 apply_default_init_local (gfc_symbol
*sym
)
10562 gfc_expr
*init
= NULL
;
10564 /* The symbol should be a variable or a function return value. */
10565 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10566 || (sym
->attr
.function
&& sym
->result
!= sym
))
10569 /* Try to build the initializer expression. If we can't initialize
10570 this symbol, then init will be NULL. */
10571 init
= build_default_init_expr (sym
);
10575 /* For saved variables, we don't want to add an initializer at function
10576 entry, so we just add a static initializer. Note that automatic variables
10577 are stack allocated even with -fno-automatic; we have also to exclude
10578 result variable, which are also nonstatic. */
10579 if (sym
->attr
.save
|| sym
->ns
->save_all
10580 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10581 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10583 /* Don't clobber an existing initializer! */
10584 gcc_assert (sym
->value
== NULL
);
10589 build_init_assign (sym
, init
);
10593 /* Resolution of common features of flavors variable and procedure. */
10596 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10598 gfc_array_spec
*as
;
10600 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10601 as
= CLASS_DATA (sym
)->as
;
10605 /* Constraints on deferred shape variable. */
10606 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10608 bool pointer
, allocatable
, dimension
;
10610 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10612 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10613 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10614 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10618 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10619 allocatable
= sym
->attr
.allocatable
;
10620 dimension
= sym
->attr
.dimension
;
10625 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10627 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10628 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10631 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10632 "'%s' at %L may not be ALLOCATABLE",
10633 sym
->name
, &sym
->declared_at
))
10637 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10639 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10640 "assumed rank", sym
->name
, &sym
->declared_at
);
10646 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10647 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10649 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10650 sym
->name
, &sym
->declared_at
);
10655 /* Constraints on polymorphic variables. */
10656 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10659 if (sym
->attr
.class_ok
10660 && !sym
->attr
.select_type_temporary
10661 && !UNLIMITED_POLY (sym
)
10662 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10664 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10665 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10666 &sym
->declared_at
);
10671 /* Assume that use associated symbols were checked in the module ns.
10672 Class-variables that are associate-names are also something special
10673 and excepted from the test. */
10674 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10676 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10677 "or pointer", sym
->name
, &sym
->declared_at
);
10686 /* Additional checks for symbols with flavor variable and derived
10687 type. To be called from resolve_fl_variable. */
10690 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10692 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10694 /* Check to see if a derived type is blocked from being host
10695 associated by the presence of another class I symbol in the same
10696 namespace. 14.6.1.3 of the standard and the discussion on
10697 comp.lang.fortran. */
10698 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10699 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10702 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10703 if (s
&& s
->attr
.generic
)
10704 s
= gfc_find_dt_in_generic (s
);
10705 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10707 gfc_error ("The type '%s' cannot be host associated at %L "
10708 "because it is blocked by an incompatible object "
10709 "of the same name declared at %L",
10710 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10716 /* 4th constraint in section 11.3: "If an object of a type for which
10717 component-initialization is specified (R429) appears in the
10718 specification-part of a module and does not have the ALLOCATABLE
10719 or POINTER attribute, the object shall have the SAVE attribute."
10721 The check for initializers is performed with
10722 gfc_has_default_initializer because gfc_default_initializer generates
10723 a hidden default for allocatable components. */
10724 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10725 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10726 && !sym
->ns
->save_all
&& !sym
->attr
.save
10727 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10728 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10729 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10730 "'%s' at %L, needed due to the default "
10731 "initialization", sym
->name
, &sym
->declared_at
))
10734 /* Assign default initializer. */
10735 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10736 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10738 sym
->value
= gfc_default_initializer (&sym
->ts
);
10745 /* Resolve symbols with flavor variable. */
10748 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10750 int no_init_flag
, automatic_flag
;
10752 const char *auto_save_msg
;
10753 bool saved_specification_expr
;
10755 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10758 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
10761 /* Set this flag to check that variables are parameters of all entries.
10762 This check is effected by the call to gfc_resolve_expr through
10763 is_non_constant_shape_array. */
10764 saved_specification_expr
= specification_expr
;
10765 specification_expr
= true;
10767 if (sym
->ns
->proc_name
10768 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10769 || sym
->ns
->proc_name
->attr
.is_main_program
)
10770 && !sym
->attr
.use_assoc
10771 && !sym
->attr
.allocatable
10772 && !sym
->attr
.pointer
10773 && is_non_constant_shape_array (sym
))
10775 /* The shape of a main program or module array needs to be
10777 gfc_error ("The module or main program array '%s' at %L must "
10778 "have constant shape", sym
->name
, &sym
->declared_at
);
10779 specification_expr
= saved_specification_expr
;
10783 /* Constraints on deferred type parameter. */
10784 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10786 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10787 "requires either the pointer or allocatable attribute",
10788 sym
->name
, &sym
->declared_at
);
10789 specification_expr
= saved_specification_expr
;
10793 if (sym
->ts
.type
== BT_CHARACTER
)
10795 /* Make sure that character string variables with assumed length are
10796 dummy arguments. */
10797 e
= sym
->ts
.u
.cl
->length
;
10798 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10799 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
10801 gfc_error ("Entity with assumed character length at %L must be a "
10802 "dummy argument or a PARAMETER", &sym
->declared_at
);
10803 specification_expr
= saved_specification_expr
;
10807 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10809 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10810 specification_expr
= saved_specification_expr
;
10814 if (!gfc_is_constant_expr (e
)
10815 && !(e
->expr_type
== EXPR_VARIABLE
10816 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10818 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10819 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10820 || sym
->ns
->proc_name
->attr
.is_main_program
))
10822 gfc_error ("'%s' at %L must have constant character length "
10823 "in this context", sym
->name
, &sym
->declared_at
);
10824 specification_expr
= saved_specification_expr
;
10827 if (sym
->attr
.in_common
)
10829 gfc_error ("COMMON variable '%s' at %L must have constant "
10830 "character length", sym
->name
, &sym
->declared_at
);
10831 specification_expr
= saved_specification_expr
;
10837 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10838 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10840 /* Determine if the symbol may not have an initializer. */
10841 no_init_flag
= automatic_flag
= 0;
10842 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10843 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10845 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10846 && is_non_constant_shape_array (sym
))
10848 no_init_flag
= automatic_flag
= 1;
10850 /* Also, they must not have the SAVE attribute.
10851 SAVE_IMPLICIT is checked below. */
10852 if (sym
->as
&& sym
->attr
.codimension
)
10854 int corank
= sym
->as
->corank
;
10855 sym
->as
->corank
= 0;
10856 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10857 sym
->as
->corank
= corank
;
10859 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10861 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10862 specification_expr
= saved_specification_expr
;
10867 /* Ensure that any initializer is simplified. */
10869 gfc_simplify_expr (sym
->value
, 1);
10871 /* Reject illegal initializers. */
10872 if (!sym
->mark
&& sym
->value
)
10874 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10875 && CLASS_DATA (sym
)->attr
.allocatable
))
10876 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10877 sym
->name
, &sym
->declared_at
);
10878 else if (sym
->attr
.external
)
10879 gfc_error ("External '%s' at %L cannot have an initializer",
10880 sym
->name
, &sym
->declared_at
);
10881 else if (sym
->attr
.dummy
10882 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10883 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10884 sym
->name
, &sym
->declared_at
);
10885 else if (sym
->attr
.intrinsic
)
10886 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10887 sym
->name
, &sym
->declared_at
);
10888 else if (sym
->attr
.result
)
10889 gfc_error ("Function result '%s' at %L cannot have an initializer",
10890 sym
->name
, &sym
->declared_at
);
10891 else if (automatic_flag
)
10892 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10893 sym
->name
, &sym
->declared_at
);
10895 goto no_init_error
;
10896 specification_expr
= saved_specification_expr
;
10901 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10903 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10904 specification_expr
= saved_specification_expr
;
10908 specification_expr
= saved_specification_expr
;
10913 /* Resolve a procedure. */
10916 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10918 gfc_formal_arglist
*arg
;
10920 if (sym
->attr
.function
10921 && !resolve_fl_var_and_proc (sym
, mp_flag
))
10924 if (sym
->ts
.type
== BT_CHARACTER
)
10926 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10928 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10929 && !resolve_charlen (cl
))
10932 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10933 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10935 gfc_error ("Character-valued statement function '%s' at %L must "
10936 "have constant length", sym
->name
, &sym
->declared_at
);
10941 /* Ensure that derived type for are not of a private type. Internal
10942 module procedures are excluded by 2.2.3.3 - i.e., they are not
10943 externally accessible and can access all the objects accessible in
10945 if (!(sym
->ns
->parent
10946 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10947 && gfc_check_symbol_access (sym
))
10949 gfc_interface
*iface
;
10951 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
10954 && arg
->sym
->ts
.type
== BT_DERIVED
10955 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10956 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10957 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
10958 "and cannot be a dummy argument"
10959 " of '%s', which is PUBLIC at %L",
10960 arg
->sym
->name
, sym
->name
,
10961 &sym
->declared_at
))
10963 /* Stop this message from recurring. */
10964 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10969 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10970 PRIVATE to the containing module. */
10971 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10973 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10976 && arg
->sym
->ts
.type
== BT_DERIVED
10977 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10978 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10979 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10980 "PUBLIC interface '%s' at %L "
10981 "takes dummy arguments of '%s' which "
10982 "is PRIVATE", iface
->sym
->name
,
10983 sym
->name
, &iface
->sym
->declared_at
,
10984 gfc_typename(&arg
->sym
->ts
)))
10986 /* Stop this message from recurring. */
10987 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10993 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10994 PRIVATE to the containing module. */
10995 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10997 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11000 && arg
->sym
->ts
.type
== BT_DERIVED
11001 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11002 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11003 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
11004 "PUBLIC interface '%s' at %L takes "
11005 "dummy arguments of '%s' which is "
11006 "PRIVATE", iface
->sym
->name
,
11007 sym
->name
, &iface
->sym
->declared_at
,
11008 gfc_typename(&arg
->sym
->ts
)))
11010 /* Stop this message from recurring. */
11011 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11018 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11019 && !sym
->attr
.proc_pointer
)
11021 gfc_error ("Function '%s' at %L cannot have an initializer",
11022 sym
->name
, &sym
->declared_at
);
11026 /* An external symbol may not have an initializer because it is taken to be
11027 a procedure. Exception: Procedure Pointers. */
11028 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11030 gfc_error ("External object '%s' at %L may not have an initializer",
11031 sym
->name
, &sym
->declared_at
);
11035 /* An elemental function is required to return a scalar 12.7.1 */
11036 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11038 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11039 "result", sym
->name
, &sym
->declared_at
);
11040 /* Reset so that the error only occurs once. */
11041 sym
->attr
.elemental
= 0;
11045 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11046 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11048 gfc_error ("Statement function '%s' at %L may not have pointer or "
11049 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11053 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11054 char-len-param shall not be array-valued, pointer-valued, recursive
11055 or pure. ....snip... A character value of * may only be used in the
11056 following ways: (i) Dummy arg of procedure - dummy associates with
11057 actual length; (ii) To declare a named constant; or (iii) External
11058 function - but length must be declared in calling scoping unit. */
11059 if (sym
->attr
.function
11060 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11061 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11063 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11064 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11066 if (sym
->as
&& sym
->as
->rank
)
11067 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11068 "array-valued", sym
->name
, &sym
->declared_at
);
11070 if (sym
->attr
.pointer
)
11071 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11072 "pointer-valued", sym
->name
, &sym
->declared_at
);
11074 if (sym
->attr
.pure
)
11075 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11076 "pure", sym
->name
, &sym
->declared_at
);
11078 if (sym
->attr
.recursive
)
11079 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11080 "recursive", sym
->name
, &sym
->declared_at
);
11085 /* Appendix B.2 of the standard. Contained functions give an
11086 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11087 character length is an F2003 feature. */
11088 if (!sym
->attr
.contained
11089 && gfc_current_form
!= FORM_FIXED
11090 && !sym
->ts
.deferred
)
11091 gfc_notify_std (GFC_STD_F95_OBS
,
11092 "CHARACTER(*) function '%s' at %L",
11093 sym
->name
, &sym
->declared_at
);
11096 /* F2008, C1218. */
11097 if (sym
->attr
.elemental
)
11099 if (sym
->attr
.proc_pointer
)
11101 gfc_error ("Procedure pointer '%s' at %L shall not be elemental",
11102 sym
->name
, &sym
->declared_at
);
11105 if (sym
->attr
.dummy
)
11107 gfc_error ("Dummy procedure '%s' at %L shall not be elemental",
11108 sym
->name
, &sym
->declared_at
);
11113 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11115 gfc_formal_arglist
*curr_arg
;
11116 int has_non_interop_arg
= 0;
11118 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11119 sym
->common_block
))
11121 /* Clear these to prevent looking at them again if there was an
11123 sym
->attr
.is_bind_c
= 0;
11124 sym
->attr
.is_c_interop
= 0;
11125 sym
->ts
.is_c_interop
= 0;
11129 /* So far, no errors have been found. */
11130 sym
->attr
.is_c_interop
= 1;
11131 sym
->ts
.is_c_interop
= 1;
11134 curr_arg
= gfc_sym_get_dummy_args (sym
);
11135 while (curr_arg
!= NULL
)
11137 /* Skip implicitly typed dummy args here. */
11138 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11139 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11140 /* If something is found to fail, record the fact so we
11141 can mark the symbol for the procedure as not being
11142 BIND(C) to try and prevent multiple errors being
11144 has_non_interop_arg
= 1;
11146 curr_arg
= curr_arg
->next
;
11149 /* See if any of the arguments were not interoperable and if so, clear
11150 the procedure symbol to prevent duplicate error messages. */
11151 if (has_non_interop_arg
!= 0)
11153 sym
->attr
.is_c_interop
= 0;
11154 sym
->ts
.is_c_interop
= 0;
11155 sym
->attr
.is_bind_c
= 0;
11159 if (!sym
->attr
.proc_pointer
)
11161 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11163 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11164 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11167 if (sym
->attr
.intent
)
11169 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11170 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11173 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11175 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11176 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11179 if (sym
->attr
.external
&& sym
->attr
.function
11180 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11181 || sym
->attr
.contained
))
11183 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11184 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11187 if (strcmp ("ppr@", sym
->name
) == 0)
11189 gfc_error ("Procedure pointer result '%s' at %L "
11190 "is missing the pointer attribute",
11191 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11200 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11201 been defined and we now know their defined arguments, check that they fulfill
11202 the requirements of the standard for procedures used as finalizers. */
11205 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11207 gfc_finalizer
* list
;
11208 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11209 bool result
= true;
11210 bool seen_scalar
= false;
11214 /* Return early when not finalizable. Additionally, ensure that derived-type
11215 components have a their finalizables resolved. */
11216 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11218 bool has_final
= false;
11219 for (c
= derived
->components
; c
; c
= c
->next
)
11220 if (c
->ts
.type
== BT_DERIVED
11221 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11223 bool has_final2
= false;
11224 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11225 return false; /* Error. */
11226 has_final
= has_final
|| has_final2
;
11231 *finalizable
= false;
11236 /* Walk over the list of finalizer-procedures, check them, and if any one
11237 does not fit in with the standard's definition, print an error and remove
11238 it from the list. */
11239 prev_link
= &derived
->f2k_derived
->finalizers
;
11240 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11242 gfc_formal_arglist
*dummy_args
;
11247 /* Skip this finalizer if we already resolved it. */
11248 if (list
->proc_tree
)
11250 prev_link
= &(list
->next
);
11254 /* Check this exists and is a SUBROUTINE. */
11255 if (!list
->proc_sym
->attr
.subroutine
)
11257 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11258 list
->proc_sym
->name
, &list
->where
);
11262 /* We should have exactly one argument. */
11263 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11264 if (!dummy_args
|| dummy_args
->next
)
11266 gfc_error ("FINAL procedure at %L must have exactly one argument",
11270 arg
= dummy_args
->sym
;
11272 /* This argument must be of our type. */
11273 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11275 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11276 &arg
->declared_at
, derived
->name
);
11280 /* It must neither be a pointer nor allocatable nor optional. */
11281 if (arg
->attr
.pointer
)
11283 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11284 &arg
->declared_at
);
11287 if (arg
->attr
.allocatable
)
11289 gfc_error ("Argument of FINAL procedure at %L must not be"
11290 " ALLOCATABLE", &arg
->declared_at
);
11293 if (arg
->attr
.optional
)
11295 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11296 &arg
->declared_at
);
11300 /* It must not be INTENT(OUT). */
11301 if (arg
->attr
.intent
== INTENT_OUT
)
11303 gfc_error ("Argument of FINAL procedure at %L must not be"
11304 " INTENT(OUT)", &arg
->declared_at
);
11308 /* Warn if the procedure is non-scalar and not assumed shape. */
11309 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11310 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11311 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11312 " shape argument", &arg
->declared_at
);
11314 /* Check that it does not match in kind and rank with a FINAL procedure
11315 defined earlier. To really loop over the *earlier* declarations,
11316 we need to walk the tail of the list as new ones were pushed at the
11318 /* TODO: Handle kind parameters once they are implemented. */
11319 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11320 for (i
= list
->next
; i
; i
= i
->next
)
11322 gfc_formal_arglist
*dummy_args
;
11324 /* Argument list might be empty; that is an error signalled earlier,
11325 but we nevertheless continued resolving. */
11326 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11329 gfc_symbol
* i_arg
= dummy_args
->sym
;
11330 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11331 if (i_rank
== my_rank
)
11333 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11334 " rank (%d) as '%s'",
11335 list
->proc_sym
->name
, &list
->where
, my_rank
,
11336 i
->proc_sym
->name
);
11342 /* Is this the/a scalar finalizer procedure? */
11343 if (!arg
->as
|| arg
->as
->rank
== 0)
11344 seen_scalar
= true;
11346 /* Find the symtree for this procedure. */
11347 gcc_assert (!list
->proc_tree
);
11348 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11350 prev_link
= &list
->next
;
11353 /* Remove wrong nodes immediately from the list so we don't risk any
11354 troubles in the future when they might fail later expectations. */
11357 *prev_link
= list
->next
;
11358 gfc_free_finalizer (i
);
11362 if (result
== false)
11365 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11366 were nodes in the list, must have been for arrays. It is surely a good
11367 idea to have a scalar version there if there's something to finalize. */
11368 if (gfc_option
.warn_surprising
&& result
&& !seen_scalar
)
11369 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11370 " defined at %L, suggest also scalar one",
11371 derived
->name
, &derived
->declared_at
);
11373 vtab
= gfc_find_derived_vtab (derived
);
11374 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11375 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11378 *finalizable
= true;
11384 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11387 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11388 const char* generic_name
, locus where
)
11390 gfc_symbol
*sym1
, *sym2
;
11391 const char *pass1
, *pass2
;
11392 gfc_formal_arglist
*dummy_args
;
11394 gcc_assert (t1
->specific
&& t2
->specific
);
11395 gcc_assert (!t1
->specific
->is_generic
);
11396 gcc_assert (!t2
->specific
->is_generic
);
11397 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11399 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11400 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11405 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11406 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11407 || sym1
->attr
.function
!= sym2
->attr
.function
)
11409 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11410 " GENERIC '%s' at %L",
11411 sym1
->name
, sym2
->name
, generic_name
, &where
);
11415 /* Determine PASS arguments. */
11416 if (t1
->specific
->nopass
)
11418 else if (t1
->specific
->pass_arg
)
11419 pass1
= t1
->specific
->pass_arg
;
11422 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
11424 pass1
= dummy_args
->sym
->name
;
11428 if (t2
->specific
->nopass
)
11430 else if (t2
->specific
->pass_arg
)
11431 pass2
= t2
->specific
->pass_arg
;
11434 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
11436 pass2
= dummy_args
->sym
->name
;
11441 /* Compare the interfaces. */
11442 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11443 NULL
, 0, pass1
, pass2
))
11445 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11446 sym1
->name
, sym2
->name
, generic_name
, &where
);
11454 /* Worker function for resolving a generic procedure binding; this is used to
11455 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11457 The difference between those cases is finding possible inherited bindings
11458 that are overridden, as one has to look for them in tb_sym_root,
11459 tb_uop_root or tb_op, respectively. Thus the caller must already find
11460 the super-type and set p->overridden correctly. */
11463 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11464 gfc_typebound_proc
* p
, const char* name
)
11466 gfc_tbp_generic
* target
;
11467 gfc_symtree
* first_target
;
11468 gfc_symtree
* inherited
;
11470 gcc_assert (p
&& p
->is_generic
);
11472 /* Try to find the specific bindings for the symtrees in our target-list. */
11473 gcc_assert (p
->u
.generic
);
11474 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11475 if (!target
->specific
)
11477 gfc_typebound_proc
* overridden_tbp
;
11478 gfc_tbp_generic
* g
;
11479 const char* target_name
;
11481 target_name
= target
->specific_st
->name
;
11483 /* Defined for this type directly. */
11484 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11486 target
->specific
= target
->specific_st
->n
.tb
;
11487 goto specific_found
;
11490 /* Look for an inherited specific binding. */
11493 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11498 gcc_assert (inherited
->n
.tb
);
11499 target
->specific
= inherited
->n
.tb
;
11500 goto specific_found
;
11504 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11505 " at %L", target_name
, name
, &p
->where
);
11508 /* Once we've found the specific binding, check it is not ambiguous with
11509 other specifics already found or inherited for the same GENERIC. */
11511 gcc_assert (target
->specific
);
11513 /* This must really be a specific binding! */
11514 if (target
->specific
->is_generic
)
11516 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11517 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11521 /* Check those already resolved on this type directly. */
11522 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11523 if (g
!= target
&& g
->specific
11524 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11527 /* Check for ambiguity with inherited specific targets. */
11528 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11529 overridden_tbp
= overridden_tbp
->overridden
)
11530 if (overridden_tbp
->is_generic
)
11532 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11534 gcc_assert (g
->specific
);
11535 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11541 /* If we attempt to "overwrite" a specific binding, this is an error. */
11542 if (p
->overridden
&& !p
->overridden
->is_generic
)
11544 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11545 " the same name", name
, &p
->where
);
11549 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11550 all must have the same attributes here. */
11551 first_target
= p
->u
.generic
->specific
->u
.specific
;
11552 gcc_assert (first_target
);
11553 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11554 p
->function
= first_target
->n
.sym
->attr
.function
;
11560 /* Resolve a GENERIC procedure binding for a derived type. */
11563 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11565 gfc_symbol
* super_type
;
11567 /* Find the overridden binding if any. */
11568 st
->n
.tb
->overridden
= NULL
;
11569 super_type
= gfc_get_derived_super_type (derived
);
11572 gfc_symtree
* overridden
;
11573 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11576 if (overridden
&& overridden
->n
.tb
)
11577 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11580 /* Resolve using worker function. */
11581 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11585 /* Retrieve the target-procedure of an operator binding and do some checks in
11586 common for intrinsic and user-defined type-bound operators. */
11589 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11591 gfc_symbol
* target_proc
;
11593 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11594 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11595 gcc_assert (target_proc
);
11597 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11598 if (target
->specific
->nopass
)
11600 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11604 return target_proc
;
11608 /* Resolve a type-bound intrinsic operator. */
11611 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11612 gfc_typebound_proc
* p
)
11614 gfc_symbol
* super_type
;
11615 gfc_tbp_generic
* target
;
11617 /* If there's already an error here, do nothing (but don't fail again). */
11621 /* Operators should always be GENERIC bindings. */
11622 gcc_assert (p
->is_generic
);
11624 /* Look for an overridden binding. */
11625 super_type
= gfc_get_derived_super_type (derived
);
11626 if (super_type
&& super_type
->f2k_derived
)
11627 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11630 p
->overridden
= NULL
;
11632 /* Resolve general GENERIC properties using worker function. */
11633 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11636 /* Check the targets to be procedures of correct interface. */
11637 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11639 gfc_symbol
* target_proc
;
11641 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11645 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11648 /* Add target to non-typebound operator list. */
11649 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11650 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11652 gfc_interface
*head
, *intr
;
11653 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11655 head
= derived
->ns
->op
[op
];
11656 intr
= gfc_get_interface ();
11657 intr
->sym
= target_proc
;
11658 intr
->where
= p
->where
;
11660 derived
->ns
->op
[op
] = intr
;
11672 /* Resolve a type-bound user operator (tree-walker callback). */
11674 static gfc_symbol
* resolve_bindings_derived
;
11675 static bool resolve_bindings_result
;
11677 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11680 resolve_typebound_user_op (gfc_symtree
* stree
)
11682 gfc_symbol
* super_type
;
11683 gfc_tbp_generic
* target
;
11685 gcc_assert (stree
&& stree
->n
.tb
);
11687 if (stree
->n
.tb
->error
)
11690 /* Operators should always be GENERIC bindings. */
11691 gcc_assert (stree
->n
.tb
->is_generic
);
11693 /* Find overridden procedure, if any. */
11694 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11695 if (super_type
&& super_type
->f2k_derived
)
11697 gfc_symtree
* overridden
;
11698 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11699 stree
->name
, true, NULL
);
11701 if (overridden
&& overridden
->n
.tb
)
11702 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11705 stree
->n
.tb
->overridden
= NULL
;
11707 /* Resolve basically using worker function. */
11708 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11711 /* Check the targets to be functions of correct interface. */
11712 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11714 gfc_symbol
* target_proc
;
11716 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11720 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11727 resolve_bindings_result
= false;
11728 stree
->n
.tb
->error
= 1;
11732 /* Resolve the type-bound procedures for a derived type. */
11735 resolve_typebound_procedure (gfc_symtree
* stree
)
11739 gfc_symbol
* me_arg
;
11740 gfc_symbol
* super_type
;
11741 gfc_component
* comp
;
11743 gcc_assert (stree
);
11745 /* Undefined specific symbol from GENERIC target definition. */
11749 if (stree
->n
.tb
->error
)
11752 /* If this is a GENERIC binding, use that routine. */
11753 if (stree
->n
.tb
->is_generic
)
11755 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11760 /* Get the target-procedure to check it. */
11761 gcc_assert (!stree
->n
.tb
->is_generic
);
11762 gcc_assert (stree
->n
.tb
->u
.specific
);
11763 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11764 where
= stree
->n
.tb
->where
;
11766 /* Default access should already be resolved from the parser. */
11767 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11769 if (stree
->n
.tb
->deferred
)
11771 if (!check_proc_interface (proc
, &where
))
11776 /* Check for F08:C465. */
11777 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11778 || (proc
->attr
.proc
!= PROC_MODULE
11779 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11780 || proc
->attr
.abstract
)
11782 gfc_error ("'%s' must be a module procedure or an external procedure with"
11783 " an explicit interface at %L", proc
->name
, &where
);
11788 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11789 stree
->n
.tb
->function
= proc
->attr
.function
;
11791 /* Find the super-type of the current derived type. We could do this once and
11792 store in a global if speed is needed, but as long as not I believe this is
11793 more readable and clearer. */
11794 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11796 /* If PASS, resolve and check arguments if not already resolved / loaded
11797 from a .mod file. */
11798 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11800 gfc_formal_arglist
*dummy_args
;
11802 dummy_args
= gfc_sym_get_dummy_args (proc
);
11803 if (stree
->n
.tb
->pass_arg
)
11805 gfc_formal_arglist
*i
;
11807 /* If an explicit passing argument name is given, walk the arg-list
11808 and look for it. */
11811 stree
->n
.tb
->pass_arg_num
= 1;
11812 for (i
= dummy_args
; i
; i
= i
->next
)
11814 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11819 ++stree
->n
.tb
->pass_arg_num
;
11824 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11826 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11827 stree
->n
.tb
->pass_arg
);
11833 /* Otherwise, take the first one; there should in fact be at least
11835 stree
->n
.tb
->pass_arg_num
= 1;
11838 gfc_error ("Procedure '%s' with PASS at %L must have at"
11839 " least one argument", proc
->name
, &where
);
11842 me_arg
= dummy_args
->sym
;
11845 /* Now check that the argument-type matches and the passed-object
11846 dummy argument is generally fine. */
11848 gcc_assert (me_arg
);
11850 if (me_arg
->ts
.type
!= BT_CLASS
)
11852 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11853 " at %L", proc
->name
, &where
);
11857 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11858 != resolve_bindings_derived
)
11860 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11861 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11862 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11866 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11867 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11869 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11870 " scalar", proc
->name
, &where
);
11873 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11875 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11876 " be ALLOCATABLE", proc
->name
, &where
);
11879 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11881 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11882 " be POINTER", proc
->name
, &where
);
11887 /* If we are extending some type, check that we don't override a procedure
11888 flagged NON_OVERRIDABLE. */
11889 stree
->n
.tb
->overridden
= NULL
;
11892 gfc_symtree
* overridden
;
11893 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11894 stree
->name
, true, NULL
);
11898 if (overridden
->n
.tb
)
11899 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11901 if (!gfc_check_typebound_override (stree
, overridden
))
11906 /* See if there's a name collision with a component directly in this type. */
11907 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11908 if (!strcmp (comp
->name
, stree
->name
))
11910 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11912 stree
->name
, &where
, resolve_bindings_derived
->name
);
11916 /* Try to find a name collision with an inherited component. */
11917 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11919 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11920 " component of '%s'",
11921 stree
->name
, &where
, resolve_bindings_derived
->name
);
11925 stree
->n
.tb
->error
= 0;
11929 resolve_bindings_result
= false;
11930 stree
->n
.tb
->error
= 1;
11935 resolve_typebound_procedures (gfc_symbol
* derived
)
11938 gfc_symbol
* super_type
;
11940 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11943 super_type
= gfc_get_derived_super_type (derived
);
11945 resolve_symbol (super_type
);
11947 resolve_bindings_derived
= derived
;
11948 resolve_bindings_result
= true;
11950 if (derived
->f2k_derived
->tb_sym_root
)
11951 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11952 &resolve_typebound_procedure
);
11954 if (derived
->f2k_derived
->tb_uop_root
)
11955 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11956 &resolve_typebound_user_op
);
11958 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11960 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11961 if (p
&& !resolve_typebound_intrinsic_op (derived
,
11962 (gfc_intrinsic_op
)op
, p
))
11963 resolve_bindings_result
= false;
11966 return resolve_bindings_result
;
11970 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11971 to give all identical derived types the same backend_decl. */
11973 add_dt_to_dt_list (gfc_symbol
*derived
)
11975 gfc_dt_list
*dt_list
;
11977 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11978 if (derived
== dt_list
->derived
)
11981 dt_list
= gfc_get_dt_list ();
11982 dt_list
->next
= gfc_derived_types
;
11983 dt_list
->derived
= derived
;
11984 gfc_derived_types
= dt_list
;
11988 /* Ensure that a derived-type is really not abstract, meaning that every
11989 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11992 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11997 if (!ensure_not_abstract_walker (sub
, st
->left
))
11999 if (!ensure_not_abstract_walker (sub
, st
->right
))
12002 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12004 gfc_symtree
* overriding
;
12005 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12008 gcc_assert (overriding
->n
.tb
);
12009 if (overriding
->n
.tb
->deferred
)
12011 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
12012 " '%s' is DEFERRED and not overridden",
12013 sub
->name
, &sub
->declared_at
, st
->name
);
12022 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12024 /* The algorithm used here is to recursively travel up the ancestry of sub
12025 and for each ancestor-type, check all bindings. If any of them is
12026 DEFERRED, look it up starting from sub and see if the found (overriding)
12027 binding is not DEFERRED.
12028 This is not the most efficient way to do this, but it should be ok and is
12029 clearer than something sophisticated. */
12031 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12033 if (!ancestor
->attr
.abstract
)
12036 /* Walk bindings of this ancestor. */
12037 if (ancestor
->f2k_derived
)
12040 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12045 /* Find next ancestor type and recurse on it. */
12046 ancestor
= gfc_get_derived_super_type (ancestor
);
12048 return ensure_not_abstract (sub
, ancestor
);
12054 /* This check for typebound defined assignments is done recursively
12055 since the order in which derived types are resolved is not always in
12056 order of the declarations. */
12059 check_defined_assignments (gfc_symbol
*derived
)
12063 for (c
= derived
->components
; c
; c
= c
->next
)
12065 if (c
->ts
.type
!= BT_DERIVED
12067 || c
->attr
.allocatable
12068 || c
->attr
.proc_pointer_comp
12069 || c
->attr
.class_pointer
12070 || c
->attr
.proc_pointer
)
12073 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12074 || (c
->ts
.u
.derived
->f2k_derived
12075 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12077 derived
->attr
.defined_assign_comp
= 1;
12081 check_defined_assignments (c
->ts
.u
.derived
);
12082 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12084 derived
->attr
.defined_assign_comp
= 1;
12091 /* Resolve the components of a derived type. This does not have to wait until
12092 resolution stage, but can be done as soon as the dt declaration has been
12096 resolve_fl_derived0 (gfc_symbol
*sym
)
12098 gfc_symbol
* super_type
;
12101 if (sym
->attr
.unlimited_polymorphic
)
12104 super_type
= gfc_get_derived_super_type (sym
);
12107 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12109 gfc_error ("As extending type '%s' at %L has a coarray component, "
12110 "parent type '%s' shall also have one", sym
->name
,
12111 &sym
->declared_at
, super_type
->name
);
12115 /* Ensure the extended type gets resolved before we do. */
12116 if (super_type
&& !resolve_fl_derived0 (super_type
))
12119 /* An ABSTRACT type must be extensible. */
12120 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12122 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12123 sym
->name
, &sym
->declared_at
);
12127 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12130 for ( ; c
!= NULL
; c
= c
->next
)
12132 if (c
->attr
.artificial
)
12136 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12137 && c
->attr
.codimension
12138 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12140 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12141 "deferred shape", c
->name
, &c
->loc
);
12146 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12147 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12149 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12150 "shall not be a coarray", c
->name
, &c
->loc
);
12155 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12156 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12157 || c
->attr
.allocatable
))
12159 gfc_error ("Component '%s' at %L with coarray component "
12160 "shall be a nonpointer, nonallocatable scalar",
12166 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12168 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12169 "is not an array pointer", c
->name
, &c
->loc
);
12173 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12175 gfc_symbol
*ifc
= c
->ts
.interface
;
12177 if (!sym
->attr
.vtype
12178 && !check_proc_interface (ifc
, &c
->loc
))
12181 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12183 /* Resolve interface and copy attributes. */
12184 if (ifc
->formal
&& !ifc
->formal_ns
)
12185 resolve_symbol (ifc
);
12186 if (ifc
->attr
.intrinsic
)
12187 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12191 c
->ts
= ifc
->result
->ts
;
12192 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12193 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12194 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12195 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12196 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12201 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12202 c
->attr
.pointer
= ifc
->attr
.pointer
;
12203 c
->attr
.dimension
= ifc
->attr
.dimension
;
12204 c
->as
= gfc_copy_array_spec (ifc
->as
);
12205 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12207 c
->ts
.interface
= ifc
;
12208 c
->attr
.function
= ifc
->attr
.function
;
12209 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12211 c
->attr
.pure
= ifc
->attr
.pure
;
12212 c
->attr
.elemental
= ifc
->attr
.elemental
;
12213 c
->attr
.recursive
= ifc
->attr
.recursive
;
12214 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12215 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12216 /* Copy char length. */
12217 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12219 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12220 if (cl
->length
&& !cl
->resolved
12221 && !gfc_resolve_expr (cl
->length
))
12227 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12229 /* Since PPCs are not implicitly typed, a PPC without an explicit
12230 interface must be a subroutine. */
12231 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12234 /* Procedure pointer components: Check PASS arg. */
12235 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12236 && !sym
->attr
.vtype
)
12238 gfc_symbol
* me_arg
;
12240 if (c
->tb
->pass_arg
)
12242 gfc_formal_arglist
* i
;
12244 /* If an explicit passing argument name is given, walk the arg-list
12245 and look for it. */
12248 c
->tb
->pass_arg_num
= 1;
12249 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12251 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12256 c
->tb
->pass_arg_num
++;
12261 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12262 "at %L has no argument '%s'", c
->name
,
12263 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12270 /* Otherwise, take the first one; there should in fact be at least
12272 c
->tb
->pass_arg_num
= 1;
12273 if (!c
->ts
.interface
->formal
)
12275 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12276 "must have at least one argument",
12281 me_arg
= c
->ts
.interface
->formal
->sym
;
12284 /* Now check that the argument-type matches. */
12285 gcc_assert (me_arg
);
12286 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12287 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12288 || (me_arg
->ts
.type
== BT_CLASS
12289 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12291 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12292 " the derived type '%s'", me_arg
->name
, c
->name
,
12293 me_arg
->name
, &c
->loc
, sym
->name
);
12298 /* Check for C453. */
12299 if (me_arg
->attr
.dimension
)
12301 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12302 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12308 if (me_arg
->attr
.pointer
)
12310 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12311 "may not have the POINTER attribute", me_arg
->name
,
12312 c
->name
, me_arg
->name
, &c
->loc
);
12317 if (me_arg
->attr
.allocatable
)
12319 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12320 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12321 me_arg
->name
, &c
->loc
);
12326 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12327 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12328 " at %L", c
->name
, &c
->loc
);
12332 /* Check type-spec if this is not the parent-type component. */
12333 if (((sym
->attr
.is_class
12334 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12335 || c
!= sym
->components
->ts
.u
.derived
->components
))
12336 || (!sym
->attr
.is_class
12337 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12338 && !sym
->attr
.vtype
12339 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12342 /* If this type is an extension, set the accessibility of the parent
12345 && ((sym
->attr
.is_class
12346 && c
== sym
->components
->ts
.u
.derived
->components
)
12347 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12348 && strcmp (super_type
->name
, c
->name
) == 0)
12349 c
->attr
.access
= super_type
->attr
.access
;
12351 /* If this type is an extension, see if this component has the same name
12352 as an inherited type-bound procedure. */
12353 if (super_type
&& !sym
->attr
.is_class
12354 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12356 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12357 " inherited type-bound procedure",
12358 c
->name
, sym
->name
, &c
->loc
);
12362 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12363 && !c
->ts
.deferred
)
12365 if (c
->ts
.u
.cl
->length
== NULL
12366 || (!resolve_charlen(c
->ts
.u
.cl
))
12367 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12369 gfc_error ("Character length of component '%s' needs to "
12370 "be a constant specification expression at %L",
12372 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12377 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12378 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12380 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12381 "length must be a POINTER or ALLOCATABLE",
12382 c
->name
, sym
->name
, &c
->loc
);
12386 /* Add the hidden deferred length field. */
12387 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
12388 && !sym
->attr
.is_class
)
12390 char name
[GFC_MAX_SYMBOL_LEN
+9];
12391 gfc_component
*strlen
;
12392 sprintf (name
, "_%s_length", c
->name
);
12393 strlen
= gfc_find_component (sym
, name
, true, true);
12394 if (strlen
== NULL
)
12396 if (!gfc_add_component (sym
, name
, &strlen
))
12398 strlen
->ts
.type
= BT_INTEGER
;
12399 strlen
->ts
.kind
= gfc_charlen_int_kind
;
12400 strlen
->attr
.access
= ACCESS_PRIVATE
;
12401 strlen
->attr
.deferred_parameter
= 1;
12405 if (c
->ts
.type
== BT_DERIVED
12406 && sym
->component_access
!= ACCESS_PRIVATE
12407 && gfc_check_symbol_access (sym
)
12408 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12409 && !c
->ts
.u
.derived
->attr
.use_assoc
12410 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12411 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12412 "PRIVATE type and cannot be a component of "
12413 "'%s', which is PUBLIC at %L", c
->name
,
12414 sym
->name
, &sym
->declared_at
))
12417 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12419 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12420 "type %s", c
->name
, &c
->loc
, sym
->name
);
12424 if (sym
->attr
.sequence
)
12426 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12428 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12429 "not have the SEQUENCE attribute",
12430 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12435 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12436 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12437 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12438 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12439 CLASS_DATA (c
)->ts
.u
.derived
12440 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12442 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12443 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12444 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12446 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12447 "that has not been declared", c
->name
, sym
->name
,
12452 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12453 && CLASS_DATA (c
)->attr
.class_pointer
12454 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12455 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12456 && !UNLIMITED_POLY (c
))
12458 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12459 "that has not been declared", c
->name
, sym
->name
,
12465 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12466 && (!c
->attr
.class_ok
12467 || !(CLASS_DATA (c
)->attr
.class_pointer
12468 || CLASS_DATA (c
)->attr
.allocatable
)))
12470 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12471 "or pointer", c
->name
, &c
->loc
);
12472 /* Prevent a recurrence of the error. */
12473 c
->ts
.type
= BT_UNKNOWN
;
12477 /* Ensure that all the derived type components are put on the
12478 derived type list; even in formal namespaces, where derived type
12479 pointer components might not have been declared. */
12480 if (c
->ts
.type
== BT_DERIVED
12482 && c
->ts
.u
.derived
->components
12484 && sym
!= c
->ts
.u
.derived
)
12485 add_dt_to_dt_list (c
->ts
.u
.derived
);
12487 if (!gfc_resolve_array_spec (c
->as
,
12488 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12489 || c
->attr
.allocatable
)))
12492 if (c
->initializer
&& !sym
->attr
.vtype
12493 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12497 check_defined_assignments (sym
);
12499 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12500 sym
->attr
.defined_assign_comp
12501 = super_type
->attr
.defined_assign_comp
;
12503 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12504 all DEFERRED bindings are overridden. */
12505 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12506 && !sym
->attr
.is_class
12507 && !ensure_not_abstract (sym
, super_type
))
12510 /* Add derived type to the derived type list. */
12511 add_dt_to_dt_list (sym
);
12517 /* The following procedure does the full resolution of a derived type,
12518 including resolution of all type-bound procedures (if present). In contrast
12519 to 'resolve_fl_derived0' this can only be done after the module has been
12520 parsed completely. */
12523 resolve_fl_derived (gfc_symbol
*sym
)
12525 gfc_symbol
*gen_dt
= NULL
;
12527 if (sym
->attr
.unlimited_polymorphic
)
12530 if (!sym
->attr
.is_class
)
12531 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12532 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12533 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12534 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12535 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12536 "'%s' at %L being the same name as derived "
12537 "type at %L", sym
->name
,
12538 gen_dt
->generic
->sym
== sym
12539 ? gen_dt
->generic
->next
->sym
->name
12540 : gen_dt
->generic
->sym
->name
,
12541 gen_dt
->generic
->sym
== sym
12542 ? &gen_dt
->generic
->next
->sym
->declared_at
12543 : &gen_dt
->generic
->sym
->declared_at
,
12544 &sym
->declared_at
))
12547 /* Resolve the finalizer procedures. */
12548 if (!gfc_resolve_finalizers (sym
, NULL
))
12551 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12553 /* Fix up incomplete CLASS symbols. */
12554 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12555 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12557 /* Nothing more to do for unlimited polymorphic entities. */
12558 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12560 else if (vptr
->ts
.u
.derived
== NULL
)
12562 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12564 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12568 if (!resolve_fl_derived0 (sym
))
12571 /* Resolve the type-bound procedures. */
12572 if (!resolve_typebound_procedures (sym
))
12580 resolve_fl_namelist (gfc_symbol
*sym
)
12585 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12587 /* Check again, the check in match only works if NAMELIST comes
12589 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12591 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12592 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12596 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12597 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12598 "with assumed shape in namelist '%s' at %L",
12599 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12602 if (is_non_constant_shape_array (nl
->sym
)
12603 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12604 "with nonconstant shape in namelist '%s' at %L",
12605 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12608 if (nl
->sym
->ts
.type
== BT_CHARACTER
12609 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12610 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12611 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12612 "nonconstant character length in "
12613 "namelist '%s' at %L", nl
->sym
->name
,
12614 sym
->name
, &sym
->declared_at
))
12617 /* FIXME: Once UDDTIO is implemented, the following can be
12619 if (nl
->sym
->ts
.type
== BT_CLASS
)
12621 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12622 "polymorphic and requires a defined input/output "
12623 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12627 if (nl
->sym
->ts
.type
== BT_DERIVED
12628 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12629 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12631 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12632 "namelist '%s' at %L with ALLOCATABLE "
12633 "or POINTER components", nl
->sym
->name
,
12634 sym
->name
, &sym
->declared_at
))
12637 /* FIXME: Once UDDTIO is implemented, the following can be
12639 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12640 "ALLOCATABLE or POINTER components and thus requires "
12641 "a defined input/output procedure", nl
->sym
->name
,
12642 sym
->name
, &sym
->declared_at
);
12647 /* Reject PRIVATE objects in a PUBLIC namelist. */
12648 if (gfc_check_symbol_access (sym
))
12650 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12652 if (!nl
->sym
->attr
.use_assoc
12653 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12654 && !gfc_check_symbol_access (nl
->sym
))
12656 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12657 "cannot be member of PUBLIC namelist '%s' at %L",
12658 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12662 /* Types with private components that came here by USE-association. */
12663 if (nl
->sym
->ts
.type
== BT_DERIVED
12664 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12666 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12667 "components and cannot be member of namelist '%s' at %L",
12668 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12672 /* Types with private components that are defined in the same module. */
12673 if (nl
->sym
->ts
.type
== BT_DERIVED
12674 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12675 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12677 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12678 "cannot be a member of PUBLIC namelist '%s' at %L",
12679 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12686 /* 14.1.2 A module or internal procedure represent local entities
12687 of the same type as a namelist member and so are not allowed. */
12688 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12690 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12693 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12694 if ((nl
->sym
== sym
->ns
->proc_name
)
12696 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12701 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12702 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12704 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12705 "attribute in '%s' at %L", nlsym
->name
,
12706 &sym
->declared_at
);
12716 resolve_fl_parameter (gfc_symbol
*sym
)
12718 /* A parameter array's shape needs to be constant. */
12719 if (sym
->as
!= NULL
12720 && (sym
->as
->type
== AS_DEFERRED
12721 || is_non_constant_shape_array (sym
)))
12723 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12724 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12728 /* Make sure a parameter that has been implicitly typed still
12729 matches the implicit type, since PARAMETER statements can precede
12730 IMPLICIT statements. */
12731 if (sym
->attr
.implicit_type
12732 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12735 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12736 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12740 /* Make sure the types of derived parameters are consistent. This
12741 type checking is deferred until resolution because the type may
12742 refer to a derived type from the host. */
12743 if (sym
->ts
.type
== BT_DERIVED
12744 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12746 gfc_error ("Incompatible derived type in PARAMETER at %L",
12747 &sym
->value
->where
);
12754 /* Do anything necessary to resolve a symbol. Right now, we just
12755 assume that an otherwise unknown symbol is a variable. This sort
12756 of thing commonly happens for symbols in module. */
12759 resolve_symbol (gfc_symbol
*sym
)
12761 int check_constant
, mp_flag
;
12762 gfc_symtree
*symtree
;
12763 gfc_symtree
*this_symtree
;
12766 symbol_attribute class_attr
;
12767 gfc_array_spec
*as
;
12768 bool saved_specification_expr
;
12774 if (sym
->attr
.artificial
)
12777 if (sym
->attr
.unlimited_polymorphic
)
12780 if (sym
->attr
.flavor
== FL_UNKNOWN
12781 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12782 && !sym
->attr
.generic
&& !sym
->attr
.external
12783 && sym
->attr
.if_source
== IFSRC_UNKNOWN
12784 && sym
->ts
.type
== BT_UNKNOWN
))
12787 /* If we find that a flavorless symbol is an interface in one of the
12788 parent namespaces, find its symtree in this namespace, free the
12789 symbol and set the symtree to point to the interface symbol. */
12790 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12792 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12793 if (symtree
&& (symtree
->n
.sym
->generic
||
12794 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12795 && sym
->ns
->construct_entities
)))
12797 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12799 gfc_release_symbol (sym
);
12800 symtree
->n
.sym
->refs
++;
12801 this_symtree
->n
.sym
= symtree
->n
.sym
;
12806 /* Otherwise give it a flavor according to such attributes as
12808 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12809 && sym
->attr
.intrinsic
== 0)
12810 sym
->attr
.flavor
= FL_VARIABLE
;
12811 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12813 sym
->attr
.flavor
= FL_PROCEDURE
;
12814 if (sym
->attr
.dimension
)
12815 sym
->attr
.function
= 1;
12819 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12820 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12822 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12823 && !resolve_procedure_interface (sym
))
12826 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12827 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12829 if (sym
->attr
.external
)
12830 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12831 "at %L", &sym
->declared_at
);
12833 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12834 "at %L", &sym
->declared_at
);
12839 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
12842 /* Symbols that are module procedures with results (functions) have
12843 the types and array specification copied for type checking in
12844 procedures that call them, as well as for saving to a module
12845 file. These symbols can't stand the scrutiny that their results
12847 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12849 /* Make sure that the intrinsic is consistent with its internal
12850 representation. This needs to be done before assigning a default
12851 type to avoid spurious warnings. */
12852 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12853 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
12856 /* Resolve associate names. */
12858 resolve_assoc_var (sym
, true);
12860 /* Assign default type to symbols that need one and don't have one. */
12861 if (sym
->ts
.type
== BT_UNKNOWN
)
12863 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12865 gfc_set_default_type (sym
, 1, NULL
);
12868 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12869 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12870 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12871 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12873 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12875 /* The specific case of an external procedure should emit an error
12876 in the case that there is no implicit type. */
12878 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12881 /* Result may be in another namespace. */
12882 resolve_symbol (sym
->result
);
12884 if (!sym
->result
->attr
.proc_pointer
)
12886 sym
->ts
= sym
->result
->ts
;
12887 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12888 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12889 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12890 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12891 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12896 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12898 bool saved_specification_expr
= specification_expr
;
12899 specification_expr
= true;
12900 gfc_resolve_array_spec (sym
->result
->as
, false);
12901 specification_expr
= saved_specification_expr
;
12904 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12906 as
= CLASS_DATA (sym
)->as
;
12907 class_attr
= CLASS_DATA (sym
)->attr
;
12908 class_attr
.pointer
= class_attr
.class_pointer
;
12912 class_attr
= sym
->attr
;
12917 if (sym
->attr
.contiguous
12918 && (!class_attr
.dimension
12919 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12920 && !class_attr
.pointer
)))
12922 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12923 "array pointer or an assumed-shape or assumed-rank array",
12924 sym
->name
, &sym
->declared_at
);
12928 /* Assumed size arrays and assumed shape arrays must be dummy
12929 arguments. Array-spec's of implied-shape should have been resolved to
12930 AS_EXPLICIT already. */
12934 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12935 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12936 || as
->type
== AS_ASSUMED_SHAPE
)
12937 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
12939 if (as
->type
== AS_ASSUMED_SIZE
)
12940 gfc_error ("Assumed size array at %L must be a dummy argument",
12941 &sym
->declared_at
);
12943 gfc_error ("Assumed shape array at %L must be a dummy argument",
12944 &sym
->declared_at
);
12947 /* TS 29113, C535a. */
12948 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
12949 && !sym
->attr
.select_type_temporary
)
12951 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12952 &sym
->declared_at
);
12955 if (as
->type
== AS_ASSUMED_RANK
12956 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12958 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12959 "CODIMENSION attribute", &sym
->declared_at
);
12964 /* Make sure symbols with known intent or optional are really dummy
12965 variable. Because of ENTRY statement, this has to be deferred
12966 until resolution time. */
12968 if (!sym
->attr
.dummy
12969 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12971 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12975 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12977 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12978 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12982 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12984 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12985 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12987 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12988 "attribute must have constant length",
12989 sym
->name
, &sym
->declared_at
);
12993 if (sym
->ts
.is_c_interop
12994 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12996 gfc_error ("C interoperable character dummy variable '%s' at %L "
12997 "with VALUE attribute must have length one",
12998 sym
->name
, &sym
->declared_at
);
13003 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13004 && sym
->ts
.u
.derived
->attr
.generic
)
13006 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13007 if (!sym
->ts
.u
.derived
)
13009 gfc_error ("The derived type '%s' at %L is of type '%s', "
13010 "which has not been defined", sym
->name
,
13011 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13012 sym
->ts
.type
= BT_UNKNOWN
;
13017 /* Use the same constraints as TYPE(*), except for the type check
13018 and that only scalars and assumed-size arrays are permitted. */
13019 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13021 if (!sym
->attr
.dummy
)
13023 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13024 "a dummy argument", sym
->name
, &sym
->declared_at
);
13028 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13029 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13030 && sym
->ts
.type
!= BT_COMPLEX
)
13032 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13033 "of type TYPE(*) or of an numeric intrinsic type",
13034 sym
->name
, &sym
->declared_at
);
13038 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13039 || sym
->attr
.pointer
|| sym
->attr
.value
)
13041 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13042 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13043 "attribute", sym
->name
, &sym
->declared_at
);
13047 if (sym
->attr
.intent
== INTENT_OUT
)
13049 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13050 "have the INTENT(OUT) attribute",
13051 sym
->name
, &sym
->declared_at
);
13054 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13056 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13057 "either be a scalar or an assumed-size array",
13058 sym
->name
, &sym
->declared_at
);
13062 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13063 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13065 sym
->ts
.type
= BT_ASSUMED
;
13066 sym
->as
= gfc_get_array_spec ();
13067 sym
->as
->type
= AS_ASSUMED_SIZE
;
13069 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13071 else if (sym
->ts
.type
== BT_ASSUMED
)
13073 /* TS 29113, C407a. */
13074 if (!sym
->attr
.dummy
)
13076 gfc_error ("Assumed type of variable %s at %L is only permitted "
13077 "for dummy variables", sym
->name
, &sym
->declared_at
);
13080 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13081 || sym
->attr
.pointer
|| sym
->attr
.value
)
13083 gfc_error ("Assumed-type variable %s at %L may not have the "
13084 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13085 sym
->name
, &sym
->declared_at
);
13088 if (sym
->attr
.intent
== INTENT_OUT
)
13090 gfc_error ("Assumed-type variable %s at %L may not have the "
13091 "INTENT(OUT) attribute",
13092 sym
->name
, &sym
->declared_at
);
13095 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13097 gfc_error ("Assumed-type variable %s at %L shall not be an "
13098 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13103 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13104 do this for something that was implicitly typed because that is handled
13105 in gfc_set_default_type. Handle dummy arguments and procedure
13106 definitions separately. Also, anything that is use associated is not
13107 handled here but instead is handled in the module it is declared in.
13108 Finally, derived type definitions are allowed to be BIND(C) since that
13109 only implies that they're interoperable, and they are checked fully for
13110 interoperability when a variable is declared of that type. */
13111 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13112 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13113 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13117 /* First, make sure the variable is declared at the
13118 module-level scope (J3/04-007, Section 15.3). */
13119 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13120 sym
->attr
.in_common
== 0)
13122 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13123 "is neither a COMMON block nor declared at the "
13124 "module level scope", sym
->name
, &(sym
->declared_at
));
13127 else if (sym
->common_head
!= NULL
)
13129 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13133 /* If type() declaration, we need to verify that the components
13134 of the given type are all C interoperable, etc. */
13135 if (sym
->ts
.type
== BT_DERIVED
&&
13136 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13138 /* Make sure the user marked the derived type as BIND(C). If
13139 not, call the verify routine. This could print an error
13140 for the derived type more than once if multiple variables
13141 of that type are declared. */
13142 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13143 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13147 /* Verify the variable itself as C interoperable if it
13148 is BIND(C). It is not possible for this to succeed if
13149 the verify_bind_c_derived_type failed, so don't have to handle
13150 any error returned by verify_bind_c_derived_type. */
13151 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13152 sym
->common_block
);
13157 /* clear the is_bind_c flag to prevent reporting errors more than
13158 once if something failed. */
13159 sym
->attr
.is_bind_c
= 0;
13164 /* If a derived type symbol has reached this point, without its
13165 type being declared, we have an error. Notice that most
13166 conditions that produce undefined derived types have already
13167 been dealt with. However, the likes of:
13168 implicit type(t) (t) ..... call foo (t) will get us here if
13169 the type is not declared in the scope of the implicit
13170 statement. Change the type to BT_UNKNOWN, both because it is so
13171 and to prevent an ICE. */
13172 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13173 && sym
->ts
.u
.derived
->components
== NULL
13174 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13176 gfc_error ("The derived type '%s' at %L is of type '%s', "
13177 "which has not been defined", sym
->name
,
13178 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13179 sym
->ts
.type
= BT_UNKNOWN
;
13183 /* Make sure that the derived type has been resolved and that the
13184 derived type is visible in the symbol's namespace, if it is a
13185 module function and is not PRIVATE. */
13186 if (sym
->ts
.type
== BT_DERIVED
13187 && sym
->ts
.u
.derived
->attr
.use_assoc
13188 && sym
->ns
->proc_name
13189 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13190 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13193 /* Unless the derived-type declaration is use associated, Fortran 95
13194 does not allow public entries of private derived types.
13195 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13196 161 in 95-006r3. */
13197 if (sym
->ts
.type
== BT_DERIVED
13198 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13199 && !sym
->ts
.u
.derived
->attr
.use_assoc
13200 && gfc_check_symbol_access (sym
)
13201 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13202 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13203 "derived type '%s'",
13204 (sym
->attr
.flavor
== FL_PARAMETER
)
13205 ? "parameter" : "variable",
13206 sym
->name
, &sym
->declared_at
,
13207 sym
->ts
.u
.derived
->name
))
13210 /* F2008, C1302. */
13211 if (sym
->ts
.type
== BT_DERIVED
13212 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13213 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13214 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13215 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13217 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13218 "type LOCK_TYPE must be a coarray", sym
->name
,
13219 &sym
->declared_at
);
13223 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13224 default initialization is defined (5.1.2.4.4). */
13225 if (sym
->ts
.type
== BT_DERIVED
13227 && sym
->attr
.intent
== INTENT_OUT
13229 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13231 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13233 if (c
->initializer
)
13235 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13236 "ASSUMED SIZE and so cannot have a default initializer",
13237 sym
->name
, &sym
->declared_at
);
13244 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13245 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13247 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13248 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13253 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13254 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13255 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13256 || class_attr
.codimension
)
13257 && (sym
->attr
.result
|| sym
->result
== sym
))
13259 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13260 "a coarray component", sym
->name
, &sym
->declared_at
);
13265 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13266 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13268 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13269 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13274 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13275 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13276 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13277 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13278 || class_attr
.allocatable
))
13280 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13281 "nonpointer, nonallocatable scalar, which is not a coarray",
13282 sym
->name
, &sym
->declared_at
);
13286 /* F2008, C526. The function-result case was handled above. */
13287 if (class_attr
.codimension
13288 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13289 || sym
->attr
.select_type_temporary
13290 || sym
->ns
->save_all
13291 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13292 || sym
->ns
->proc_name
->attr
.is_main_program
13293 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13295 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13296 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13300 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13301 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13303 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13304 "deferred shape", sym
->name
, &sym
->declared_at
);
13307 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13308 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13310 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13311 "deferred shape", sym
->name
, &sym
->declared_at
);
13316 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13317 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13318 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13319 || (class_attr
.codimension
&& class_attr
.allocatable
))
13320 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13322 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13323 "allocatable coarray or have coarray components",
13324 sym
->name
, &sym
->declared_at
);
13328 if (class_attr
.codimension
&& sym
->attr
.dummy
13329 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13331 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13332 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13333 sym
->ns
->proc_name
->name
);
13337 if (sym
->ts
.type
== BT_LOGICAL
13338 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13339 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13340 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13343 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13344 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13346 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13347 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13348 "%L with non-C_Bool kind in BIND(C) procedure "
13349 "'%s'", sym
->name
, &sym
->declared_at
,
13350 sym
->ns
->proc_name
->name
))
13352 else if (!gfc_logical_kinds
[i
].c_bool
13353 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13354 "'%s' at %L with non-C_Bool kind in "
13355 "BIND(C) procedure '%s'", sym
->name
,
13357 sym
->attr
.function
? sym
->name
13358 : sym
->ns
->proc_name
->name
))
13362 switch (sym
->attr
.flavor
)
13365 if (!resolve_fl_variable (sym
, mp_flag
))
13370 if (!resolve_fl_procedure (sym
, mp_flag
))
13375 if (!resolve_fl_namelist (sym
))
13380 if (!resolve_fl_parameter (sym
))
13388 /* Resolve array specifier. Check as well some constraints
13389 on COMMON blocks. */
13391 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13393 /* Set the formal_arg_flag so that check_conflict will not throw
13394 an error for host associated variables in the specification
13395 expression for an array_valued function. */
13396 if (sym
->attr
.function
&& sym
->as
)
13397 formal_arg_flag
= 1;
13399 saved_specification_expr
= specification_expr
;
13400 specification_expr
= true;
13401 gfc_resolve_array_spec (sym
->as
, check_constant
);
13402 specification_expr
= saved_specification_expr
;
13404 formal_arg_flag
= 0;
13406 /* Resolve formal namespaces. */
13407 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13408 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13409 gfc_resolve (sym
->formal_ns
);
13411 /* Make sure the formal namespace is present. */
13412 if (sym
->formal
&& !sym
->formal_ns
)
13414 gfc_formal_arglist
*formal
= sym
->formal
;
13415 while (formal
&& !formal
->sym
)
13416 formal
= formal
->next
;
13420 sym
->formal_ns
= formal
->sym
->ns
;
13421 if (sym
->ns
!= formal
->sym
->ns
)
13422 sym
->formal_ns
->refs
++;
13426 /* Check threadprivate restrictions. */
13427 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13428 && (!sym
->attr
.in_common
13429 && sym
->module
== NULL
13430 && (sym
->ns
->proc_name
== NULL
13431 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13432 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13434 /* If we have come this far we can apply default-initializers, as
13435 described in 14.7.5, to those variables that have not already
13436 been assigned one. */
13437 if (sym
->ts
.type
== BT_DERIVED
13439 && !sym
->attr
.allocatable
13440 && !sym
->attr
.alloc_comp
)
13442 symbol_attribute
*a
= &sym
->attr
;
13444 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13445 && !a
->in_common
&& !a
->use_assoc
13446 && (a
->referenced
|| a
->result
)
13447 && !(a
->function
&& sym
!= sym
->result
))
13448 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13449 apply_default_init (sym
);
13452 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13453 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13454 && !CLASS_DATA (sym
)->attr
.class_pointer
13455 && !CLASS_DATA (sym
)->attr
.allocatable
)
13456 apply_default_init (sym
);
13458 /* If this symbol has a type-spec, check it. */
13459 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13460 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13461 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13466 /************* Resolve DATA statements *************/
13470 gfc_data_value
*vnode
;
13476 /* Advance the values structure to point to the next value in the data list. */
13479 next_data_value (void)
13481 while (mpz_cmp_ui (values
.left
, 0) == 0)
13484 if (values
.vnode
->next
== NULL
)
13487 values
.vnode
= values
.vnode
->next
;
13488 mpz_set (values
.left
, values
.vnode
->repeat
);
13496 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13502 ar_type mark
= AR_UNKNOWN
;
13504 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13510 if (!gfc_resolve_expr (var
->expr
))
13514 mpz_init_set_si (offset
, 0);
13517 if (e
->expr_type
!= EXPR_VARIABLE
)
13518 gfc_internal_error ("check_data_variable(): Bad expression");
13520 sym
= e
->symtree
->n
.sym
;
13522 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13524 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13525 sym
->name
, &sym
->declared_at
);
13528 if (e
->ref
== NULL
&& sym
->as
)
13530 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13531 " declaration", sym
->name
, where
);
13535 has_pointer
= sym
->attr
.pointer
;
13537 if (gfc_is_coindexed (e
))
13539 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13544 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13546 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13550 && ref
->type
== REF_ARRAY
13551 && ref
->u
.ar
.type
!= AR_FULL
)
13553 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13554 "be a full array", sym
->name
, where
);
13559 if (e
->rank
== 0 || has_pointer
)
13561 mpz_init_set_ui (size
, 1);
13568 /* Find the array section reference. */
13569 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13571 if (ref
->type
!= REF_ARRAY
)
13573 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13579 /* Set marks according to the reference pattern. */
13580 switch (ref
->u
.ar
.type
)
13588 /* Get the start position of array section. */
13589 gfc_get_section_index (ar
, section_index
, &offset
);
13594 gcc_unreachable ();
13597 if (!gfc_array_size (e
, &size
))
13599 gfc_error ("Nonconstant array section at %L in DATA statement",
13601 mpz_clear (offset
);
13608 while (mpz_cmp_ui (size
, 0) > 0)
13610 if (!next_data_value ())
13612 gfc_error ("DATA statement at %L has more variables than values",
13618 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13622 /* If we have more than one element left in the repeat count,
13623 and we have more than one element left in the target variable,
13624 then create a range assignment. */
13625 /* FIXME: Only done for full arrays for now, since array sections
13627 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13628 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13632 if (mpz_cmp (size
, values
.left
) >= 0)
13634 mpz_init_set (range
, values
.left
);
13635 mpz_sub (size
, size
, values
.left
);
13636 mpz_set_ui (values
.left
, 0);
13640 mpz_init_set (range
, size
);
13641 mpz_sub (values
.left
, values
.left
, size
);
13642 mpz_set_ui (size
, 0);
13645 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13648 mpz_add (offset
, offset
, range
);
13655 /* Assign initial value to symbol. */
13658 mpz_sub_ui (values
.left
, values
.left
, 1);
13659 mpz_sub_ui (size
, size
, 1);
13661 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13666 if (mark
== AR_FULL
)
13667 mpz_add_ui (offset
, offset
, 1);
13669 /* Modify the array section indexes and recalculate the offset
13670 for next element. */
13671 else if (mark
== AR_SECTION
)
13672 gfc_advance_section (section_index
, ar
, &offset
);
13676 if (mark
== AR_SECTION
)
13678 for (i
= 0; i
< ar
->dimen
; i
++)
13679 mpz_clear (section_index
[i
]);
13683 mpz_clear (offset
);
13689 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13691 /* Iterate over a list of elements in a DATA statement. */
13694 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13697 iterator_stack frame
;
13698 gfc_expr
*e
, *start
, *end
, *step
;
13699 bool retval
= true;
13701 mpz_init (frame
.value
);
13704 start
= gfc_copy_expr (var
->iter
.start
);
13705 end
= gfc_copy_expr (var
->iter
.end
);
13706 step
= gfc_copy_expr (var
->iter
.step
);
13708 if (!gfc_simplify_expr (start
, 1)
13709 || start
->expr_type
!= EXPR_CONSTANT
)
13711 gfc_error ("start of implied-do loop at %L could not be "
13712 "simplified to a constant value", &start
->where
);
13716 if (!gfc_simplify_expr (end
, 1)
13717 || end
->expr_type
!= EXPR_CONSTANT
)
13719 gfc_error ("end of implied-do loop at %L could not be "
13720 "simplified to a constant value", &start
->where
);
13724 if (!gfc_simplify_expr (step
, 1)
13725 || step
->expr_type
!= EXPR_CONSTANT
)
13727 gfc_error ("step of implied-do loop at %L could not be "
13728 "simplified to a constant value", &start
->where
);
13733 mpz_set (trip
, end
->value
.integer
);
13734 mpz_sub (trip
, trip
, start
->value
.integer
);
13735 mpz_add (trip
, trip
, step
->value
.integer
);
13737 mpz_div (trip
, trip
, step
->value
.integer
);
13739 mpz_set (frame
.value
, start
->value
.integer
);
13741 frame
.prev
= iter_stack
;
13742 frame
.variable
= var
->iter
.var
->symtree
;
13743 iter_stack
= &frame
;
13745 while (mpz_cmp_ui (trip
, 0) > 0)
13747 if (!traverse_data_var (var
->list
, where
))
13753 e
= gfc_copy_expr (var
->expr
);
13754 if (!gfc_simplify_expr (e
, 1))
13761 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13763 mpz_sub_ui (trip
, trip
, 1);
13767 mpz_clear (frame
.value
);
13770 gfc_free_expr (start
);
13771 gfc_free_expr (end
);
13772 gfc_free_expr (step
);
13774 iter_stack
= frame
.prev
;
13779 /* Type resolve variables in the variable list of a DATA statement. */
13782 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13786 for (; var
; var
= var
->next
)
13788 if (var
->expr
== NULL
)
13789 t
= traverse_data_list (var
, where
);
13791 t
= check_data_variable (var
, where
);
13801 /* Resolve the expressions and iterators associated with a data statement.
13802 This is separate from the assignment checking because data lists should
13803 only be resolved once. */
13806 resolve_data_variables (gfc_data_variable
*d
)
13808 for (; d
; d
= d
->next
)
13810 if (d
->list
== NULL
)
13812 if (!gfc_resolve_expr (d
->expr
))
13817 if (!gfc_resolve_iterator (&d
->iter
, false, true))
13820 if (!resolve_data_variables (d
->list
))
13829 /* Resolve a single DATA statement. We implement this by storing a pointer to
13830 the value list into static variables, and then recursively traversing the
13831 variables list, expanding iterators and such. */
13834 resolve_data (gfc_data
*d
)
13837 if (!resolve_data_variables (d
->var
))
13840 values
.vnode
= d
->value
;
13841 if (d
->value
== NULL
)
13842 mpz_set_ui (values
.left
, 0);
13844 mpz_set (values
.left
, d
->value
->repeat
);
13846 if (!traverse_data_var (d
->var
, &d
->where
))
13849 /* At this point, we better not have any values left. */
13851 if (next_data_value ())
13852 gfc_error ("DATA statement at %L has more values than variables",
13857 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13858 accessed by host or use association, is a dummy argument to a pure function,
13859 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13860 is storage associated with any such variable, shall not be used in the
13861 following contexts: (clients of this function). */
13863 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13864 procedure. Returns zero if assignment is OK, nonzero if there is a
13867 gfc_impure_variable (gfc_symbol
*sym
)
13872 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13875 /* Check if the symbol's ns is inside the pure procedure. */
13876 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13880 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13884 proc
= sym
->ns
->proc_name
;
13885 if (sym
->attr
.dummy
13886 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13887 || proc
->attr
.function
))
13890 /* TODO: Sort out what can be storage associated, if anything, and include
13891 it here. In principle equivalences should be scanned but it does not
13892 seem to be possible to storage associate an impure variable this way. */
13897 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13898 current namespace is inside a pure procedure. */
13901 gfc_pure (gfc_symbol
*sym
)
13903 symbol_attribute attr
;
13908 /* Check if the current namespace or one of its parents
13909 belongs to a pure procedure. */
13910 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13912 sym
= ns
->proc_name
;
13916 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13924 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13928 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13929 checks if the current namespace is implicitly pure. Note that this
13930 function returns false for a PURE procedure. */
13933 gfc_implicit_pure (gfc_symbol
*sym
)
13939 /* Check if the current procedure is implicit_pure. Walk up
13940 the procedure list until we find a procedure. */
13941 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13943 sym
= ns
->proc_name
;
13947 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13952 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13953 && !sym
->attr
.pure
;
13958 gfc_unset_implicit_pure (gfc_symbol
*sym
)
13964 /* Check if the current procedure is implicit_pure. Walk up
13965 the procedure list until we find a procedure. */
13966 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13968 sym
= ns
->proc_name
;
13972 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13977 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13978 sym
->attr
.implicit_pure
= 0;
13980 sym
->attr
.pure
= 0;
13984 /* Test whether the current procedure is elemental or not. */
13987 gfc_elemental (gfc_symbol
*sym
)
13989 symbol_attribute attr
;
13992 sym
= gfc_current_ns
->proc_name
;
13997 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14001 /* Warn about unused labels. */
14004 warn_unused_fortran_label (gfc_st_label
*label
)
14009 warn_unused_fortran_label (label
->left
);
14011 if (label
->defined
== ST_LABEL_UNKNOWN
)
14014 switch (label
->referenced
)
14016 case ST_LABEL_UNKNOWN
:
14017 gfc_warning ("Label %d at %L defined but not used", label
->value
,
14021 case ST_LABEL_BAD_TARGET
:
14022 gfc_warning ("Label %d at %L defined but cannot be used",
14023 label
->value
, &label
->where
);
14030 warn_unused_fortran_label (label
->right
);
14034 /* Returns the sequence type of a symbol or sequence. */
14037 sequence_type (gfc_typespec ts
)
14046 if (ts
.u
.derived
->components
== NULL
)
14047 return SEQ_NONDEFAULT
;
14049 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14050 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14051 if (sequence_type (c
->ts
) != result
)
14057 if (ts
.kind
!= gfc_default_character_kind
)
14058 return SEQ_NONDEFAULT
;
14060 return SEQ_CHARACTER
;
14063 if (ts
.kind
!= gfc_default_integer_kind
)
14064 return SEQ_NONDEFAULT
;
14066 return SEQ_NUMERIC
;
14069 if (!(ts
.kind
== gfc_default_real_kind
14070 || ts
.kind
== gfc_default_double_kind
))
14071 return SEQ_NONDEFAULT
;
14073 return SEQ_NUMERIC
;
14076 if (ts
.kind
!= gfc_default_complex_kind
)
14077 return SEQ_NONDEFAULT
;
14079 return SEQ_NUMERIC
;
14082 if (ts
.kind
!= gfc_default_logical_kind
)
14083 return SEQ_NONDEFAULT
;
14085 return SEQ_NUMERIC
;
14088 return SEQ_NONDEFAULT
;
14093 /* Resolve derived type EQUIVALENCE object. */
14096 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14098 gfc_component
*c
= derived
->components
;
14103 /* Shall not be an object of nonsequence derived type. */
14104 if (!derived
->attr
.sequence
)
14106 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14107 "attribute to be an EQUIVALENCE object", sym
->name
,
14112 /* Shall not have allocatable components. */
14113 if (derived
->attr
.alloc_comp
)
14115 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14116 "components to be an EQUIVALENCE object",sym
->name
,
14121 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14123 gfc_error ("Derived type variable '%s' at %L with default "
14124 "initialization cannot be in EQUIVALENCE with a variable "
14125 "in COMMON", sym
->name
, &e
->where
);
14129 for (; c
; c
= c
->next
)
14131 if (c
->ts
.type
== BT_DERIVED
14132 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14135 /* Shall not be an object of sequence derived type containing a pointer
14136 in the structure. */
14137 if (c
->attr
.pointer
)
14139 gfc_error ("Derived type variable '%s' at %L with pointer "
14140 "component(s) cannot be an EQUIVALENCE object",
14141 sym
->name
, &e
->where
);
14149 /* Resolve equivalence object.
14150 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14151 an allocatable array, an object of nonsequence derived type, an object of
14152 sequence derived type containing a pointer at any level of component
14153 selection, an automatic object, a function name, an entry name, a result
14154 name, a named constant, a structure component, or a subobject of any of
14155 the preceding objects. A substring shall not have length zero. A
14156 derived type shall not have components with default initialization nor
14157 shall two objects of an equivalence group be initialized.
14158 Either all or none of the objects shall have an protected attribute.
14159 The simple constraints are done in symbol.c(check_conflict) and the rest
14160 are implemented here. */
14163 resolve_equivalence (gfc_equiv
*eq
)
14166 gfc_symbol
*first_sym
;
14169 locus
*last_where
= NULL
;
14170 seq_type eq_type
, last_eq_type
;
14171 gfc_typespec
*last_ts
;
14172 int object
, cnt_protected
;
14175 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14177 first_sym
= eq
->expr
->symtree
->n
.sym
;
14181 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14185 e
->ts
= e
->symtree
->n
.sym
->ts
;
14186 /* match_varspec might not know yet if it is seeing
14187 array reference or substring reference, as it doesn't
14189 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14191 gfc_ref
*ref
= e
->ref
;
14192 sym
= e
->symtree
->n
.sym
;
14194 if (sym
->attr
.dimension
)
14196 ref
->u
.ar
.as
= sym
->as
;
14200 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14201 if (e
->ts
.type
== BT_CHARACTER
14203 && ref
->type
== REF_ARRAY
14204 && ref
->u
.ar
.dimen
== 1
14205 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14206 && ref
->u
.ar
.stride
[0] == NULL
)
14208 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14209 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14212 /* Optimize away the (:) reference. */
14213 if (start
== NULL
&& end
== NULL
)
14216 e
->ref
= ref
->next
;
14218 e
->ref
->next
= ref
->next
;
14223 ref
->type
= REF_SUBSTRING
;
14225 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14227 ref
->u
.ss
.start
= start
;
14228 if (end
== NULL
&& e
->ts
.u
.cl
)
14229 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14230 ref
->u
.ss
.end
= end
;
14231 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14238 /* Any further ref is an error. */
14241 gcc_assert (ref
->type
== REF_ARRAY
);
14242 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14248 if (!gfc_resolve_expr (e
))
14251 sym
= e
->symtree
->n
.sym
;
14253 if (sym
->attr
.is_protected
)
14255 if (cnt_protected
> 0 && cnt_protected
!= object
)
14257 gfc_error ("Either all or none of the objects in the "
14258 "EQUIVALENCE set at %L shall have the "
14259 "PROTECTED attribute",
14264 /* Shall not equivalence common block variables in a PURE procedure. */
14265 if (sym
->ns
->proc_name
14266 && sym
->ns
->proc_name
->attr
.pure
14267 && sym
->attr
.in_common
)
14269 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14270 "object in the pure procedure '%s'",
14271 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14275 /* Shall not be a named constant. */
14276 if (e
->expr_type
== EXPR_CONSTANT
)
14278 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14279 "object", sym
->name
, &e
->where
);
14283 if (e
->ts
.type
== BT_DERIVED
14284 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14287 /* Check that the types correspond correctly:
14289 A numeric sequence structure may be equivalenced to another sequence
14290 structure, an object of default integer type, default real type, double
14291 precision real type, default logical type such that components of the
14292 structure ultimately only become associated to objects of the same
14293 kind. A character sequence structure may be equivalenced to an object
14294 of default character kind or another character sequence structure.
14295 Other objects may be equivalenced only to objects of the same type and
14296 kind parameters. */
14298 /* Identical types are unconditionally OK. */
14299 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14300 goto identical_types
;
14302 last_eq_type
= sequence_type (*last_ts
);
14303 eq_type
= sequence_type (sym
->ts
);
14305 /* Since the pair of objects is not of the same type, mixed or
14306 non-default sequences can be rejected. */
14308 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14309 "statement at %L with different type objects";
14311 && last_eq_type
== SEQ_MIXED
14312 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14313 || (eq_type
== SEQ_MIXED
14314 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14317 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14318 "statement at %L with objects of different type";
14320 && last_eq_type
== SEQ_NONDEFAULT
14321 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14322 || (eq_type
== SEQ_NONDEFAULT
14323 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14326 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14327 "EQUIVALENCE statement at %L";
14328 if (last_eq_type
== SEQ_CHARACTER
14329 && eq_type
!= SEQ_CHARACTER
14330 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14333 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14334 "EQUIVALENCE statement at %L";
14335 if (last_eq_type
== SEQ_NUMERIC
14336 && eq_type
!= SEQ_NUMERIC
14337 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14342 last_where
= &e
->where
;
14347 /* Shall not be an automatic array. */
14348 if (e
->ref
->type
== REF_ARRAY
14349 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14351 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14352 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14359 /* Shall not be a structure component. */
14360 if (r
->type
== REF_COMPONENT
)
14362 gfc_error ("Structure component '%s' at %L cannot be an "
14363 "EQUIVALENCE object",
14364 r
->u
.c
.component
->name
, &e
->where
);
14368 /* A substring shall not have length zero. */
14369 if (r
->type
== REF_SUBSTRING
)
14371 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14373 gfc_error ("Substring at %L has length zero",
14374 &r
->u
.ss
.start
->where
);
14384 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14387 resolve_fntype (gfc_namespace
*ns
)
14389 gfc_entry_list
*el
;
14392 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14395 /* If there are any entries, ns->proc_name is the entry master
14396 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14398 sym
= ns
->entries
->sym
;
14400 sym
= ns
->proc_name
;
14401 if (sym
->result
== sym
14402 && sym
->ts
.type
== BT_UNKNOWN
14403 && !gfc_set_default_type (sym
, 0, NULL
)
14404 && !sym
->attr
.untyped
)
14406 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14407 sym
->name
, &sym
->declared_at
);
14408 sym
->attr
.untyped
= 1;
14411 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14412 && !sym
->attr
.contained
14413 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14414 && gfc_check_symbol_access (sym
))
14416 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14417 "%L of PRIVATE type '%s'", sym
->name
,
14418 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14422 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14424 if (el
->sym
->result
== el
->sym
14425 && el
->sym
->ts
.type
== BT_UNKNOWN
14426 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14427 && !el
->sym
->attr
.untyped
)
14429 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14430 el
->sym
->name
, &el
->sym
->declared_at
);
14431 el
->sym
->attr
.untyped
= 1;
14437 /* 12.3.2.1.1 Defined operators. */
14440 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14442 gfc_formal_arglist
*formal
;
14444 if (!sym
->attr
.function
)
14446 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14447 sym
->name
, &where
);
14451 if (sym
->ts
.type
== BT_CHARACTER
14452 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14453 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14454 && sym
->result
->ts
.u
.cl
->length
))
14456 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14457 "character length", sym
->name
, &where
);
14461 formal
= gfc_sym_get_dummy_args (sym
);
14462 if (!formal
|| !formal
->sym
)
14464 gfc_error ("User operator procedure '%s' at %L must have at least "
14465 "one argument", sym
->name
, &where
);
14469 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14471 gfc_error ("First argument of operator interface at %L must be "
14472 "INTENT(IN)", &where
);
14476 if (formal
->sym
->attr
.optional
)
14478 gfc_error ("First argument of operator interface at %L cannot be "
14479 "optional", &where
);
14483 formal
= formal
->next
;
14484 if (!formal
|| !formal
->sym
)
14487 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14489 gfc_error ("Second argument of operator interface at %L must be "
14490 "INTENT(IN)", &where
);
14494 if (formal
->sym
->attr
.optional
)
14496 gfc_error ("Second argument of operator interface at %L cannot be "
14497 "optional", &where
);
14503 gfc_error ("Operator interface at %L must have, at most, two "
14504 "arguments", &where
);
14512 gfc_resolve_uops (gfc_symtree
*symtree
)
14514 gfc_interface
*itr
;
14516 if (symtree
== NULL
)
14519 gfc_resolve_uops (symtree
->left
);
14520 gfc_resolve_uops (symtree
->right
);
14522 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14523 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14527 /* Examine all of the expressions associated with a program unit,
14528 assign types to all intermediate expressions, make sure that all
14529 assignments are to compatible types and figure out which names
14530 refer to which functions or subroutines. It doesn't check code
14531 block, which is handled by resolve_code. */
14534 resolve_types (gfc_namespace
*ns
)
14540 gfc_namespace
* old_ns
= gfc_current_ns
;
14542 /* Check that all IMPLICIT types are ok. */
14543 if (!ns
->seen_implicit_none
)
14546 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14547 if (ns
->set_flag
[letter
]
14548 && !resolve_typespec_used (&ns
->default_type
[letter
],
14549 &ns
->implicit_loc
[letter
], NULL
))
14553 gfc_current_ns
= ns
;
14555 resolve_entries (ns
);
14557 resolve_common_vars (ns
->blank_common
.head
, false);
14558 resolve_common_blocks (ns
->common_root
);
14560 resolve_contained_functions (ns
);
14562 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14563 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14564 resolve_formal_arglist (ns
->proc_name
);
14566 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14568 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14569 resolve_charlen (cl
);
14571 gfc_traverse_ns (ns
, resolve_symbol
);
14573 resolve_fntype (ns
);
14575 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14577 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14578 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14579 "also be PURE", n
->proc_name
->name
,
14580 &n
->proc_name
->declared_at
);
14586 gfc_do_concurrent_flag
= 0;
14587 gfc_check_interfaces (ns
);
14589 gfc_traverse_ns (ns
, resolve_values
);
14595 for (d
= ns
->data
; d
; d
= d
->next
)
14599 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14601 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14603 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14604 resolve_equivalence (eq
);
14606 /* Warn about unused labels. */
14607 if (warn_unused_label
)
14608 warn_unused_fortran_label (ns
->st_labels
);
14610 gfc_resolve_uops (ns
->uop_root
);
14612 gfc_current_ns
= old_ns
;
14616 /* Call resolve_code recursively. */
14619 resolve_codes (gfc_namespace
*ns
)
14622 bitmap_obstack old_obstack
;
14624 if (ns
->resolved
== 1)
14627 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14630 gfc_current_ns
= ns
;
14632 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14633 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14636 /* Set to an out of range value. */
14637 current_entry_id
= -1;
14639 old_obstack
= labels_obstack
;
14640 bitmap_obstack_initialize (&labels_obstack
);
14642 resolve_code (ns
->code
, ns
);
14644 bitmap_obstack_release (&labels_obstack
);
14645 labels_obstack
= old_obstack
;
14649 /* This function is called after a complete program unit has been compiled.
14650 Its purpose is to examine all of the expressions associated with a program
14651 unit, assign types to all intermediate expressions, make sure that all
14652 assignments are to compatible types and figure out which names refer to
14653 which functions or subroutines. */
14656 gfc_resolve (gfc_namespace
*ns
)
14658 gfc_namespace
*old_ns
;
14659 code_stack
*old_cs_base
;
14665 old_ns
= gfc_current_ns
;
14666 old_cs_base
= cs_base
;
14668 resolve_types (ns
);
14669 component_assignment_level
= 0;
14670 resolve_codes (ns
);
14672 gfc_current_ns
= old_ns
;
14673 cs_base
= old_cs_base
;
14676 gfc_run_passes (ns
);