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 gfc_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 ("%qs at %L is of the ABSTRACT type %qs",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type %qs 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 %qs 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 %qs at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface %qs 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 %qs 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 %qs 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 %qs 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 "%qs at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "%qs 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 "%qs 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 %qs 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 %qs"
394 " of pure function %qs at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument %qs of pure function %qs 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 %qs"
407 " of pure subroutine %qs at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument %qs of pure subroutine %qs 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 %qs 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 %qs 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 %qs 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 %qs 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 %qs not allowed in elemental "
481 "procedure %qs 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 %qs of elemental procedure %qs 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 %qs 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 %qs 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 %qs at %L has no IMPLICIT type",
571 sym
->name
, &sym
->declared_at
);
572 else if (!sym
->result
->attr
.proc_pointer
)
573 gfc_error ("Result %qs of contained function %qs 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 %qs 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 %qs 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 %qs 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 ("%qs 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 %qs 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 %qs 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 %qs 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_1 ("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_1 ("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_1 ("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_1 ("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_1 ("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 %qs 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 %qs 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 %qs 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 %qs 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 %qs, 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 %qs, 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 "%qs 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 %qs 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 %qs 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 %qs 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 ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1528 gfc_error ("GENERIC procedure %qs 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
|| 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
&& warn_surprising
1647 && !sym
->attr
.implicit_type
)
1648 gfc_warning (OPT_Wsurprising
,
1649 "Type specified for intrinsic function %qs at %L is"
1650 " ignored", sym
->name
, &sym
->declared_at
);
1652 if (!sym
->attr
.function
&&
1653 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1658 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1660 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1662 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1663 " specifier", sym
->name
, &sym
->declared_at
);
1667 if (!sym
->attr
.subroutine
&&
1668 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1673 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1678 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1680 sym
->attr
.pure
= isym
->pure
;
1681 sym
->attr
.elemental
= isym
->elemental
;
1683 /* Check it is actually available in the standard settings. */
1684 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1686 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1687 "available in the current standard settings but %s. Use "
1688 "an appropriate %<-std=*%> option or enable "
1689 "%<-fall-intrinsics%> in order to use it.",
1690 sym
->name
, &sym
->declared_at
, symstd
);
1698 /* Resolve a procedure expression, like passing it to a called procedure or as
1699 RHS for a procedure pointer assignment. */
1702 resolve_procedure_expression (gfc_expr
* expr
)
1706 if (expr
->expr_type
!= EXPR_VARIABLE
)
1708 gcc_assert (expr
->symtree
);
1710 sym
= expr
->symtree
->n
.sym
;
1712 if (sym
->attr
.intrinsic
)
1713 gfc_resolve_intrinsic (sym
, &expr
->where
);
1715 if (sym
->attr
.flavor
!= FL_PROCEDURE
1716 || (sym
->attr
.function
&& sym
->result
== sym
))
1719 /* A non-RECURSIVE procedure that is used as procedure expression within its
1720 own body is in danger of being called recursively. */
1721 if (is_illegal_recursion (sym
, gfc_current_ns
))
1722 gfc_warning ("Non-RECURSIVE procedure %qs at %L is possibly calling"
1723 " itself recursively. Declare it RECURSIVE or use"
1724 " %<-frecursive%>", sym
->name
, &expr
->where
);
1730 /* Resolve an actual argument list. Most of the time, this is just
1731 resolving the expressions in the list.
1732 The exception is that we sometimes have to decide whether arguments
1733 that look like procedure arguments are really simple variable
1737 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1738 bool no_formal_args
)
1741 gfc_symtree
*parent_st
;
1743 gfc_component
*comp
;
1744 int save_need_full_assumed_size
;
1745 bool return_value
= false;
1746 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1749 first_actual_arg
= true;
1751 for (; arg
; arg
= arg
->next
)
1756 /* Check the label is a valid branching target. */
1759 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1761 gfc_error ("Label %d referenced at %L is never defined",
1762 arg
->label
->value
, &arg
->label
->where
);
1766 first_actual_arg
= false;
1770 if (e
->expr_type
== EXPR_VARIABLE
1771 && e
->symtree
->n
.sym
->attr
.generic
1773 && count_specific_procs (e
) != 1)
1776 if (e
->ts
.type
!= BT_PROCEDURE
)
1778 save_need_full_assumed_size
= need_full_assumed_size
;
1779 if (e
->expr_type
!= EXPR_VARIABLE
)
1780 need_full_assumed_size
= 0;
1781 if (!gfc_resolve_expr (e
))
1783 need_full_assumed_size
= save_need_full_assumed_size
;
1787 /* See if the expression node should really be a variable reference. */
1789 sym
= e
->symtree
->n
.sym
;
1791 if (sym
->attr
.flavor
== FL_PROCEDURE
1792 || sym
->attr
.intrinsic
1793 || sym
->attr
.external
)
1797 /* If a procedure is not already determined to be something else
1798 check if it is intrinsic. */
1799 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1800 sym
->attr
.intrinsic
= 1;
1802 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1804 gfc_error ("Statement function %qs at %L is not allowed as an "
1805 "actual argument", sym
->name
, &e
->where
);
1808 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1809 sym
->attr
.subroutine
);
1810 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1812 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1813 "actual argument", sym
->name
, &e
->where
);
1816 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1817 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1819 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1820 " used as actual argument at %L",
1821 sym
->name
, &e
->where
))
1825 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1827 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1828 "allowed as an actual argument at %L", sym
->name
,
1832 /* Check if a generic interface has a specific procedure
1833 with the same name before emitting an error. */
1834 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1837 /* Just in case a specific was found for the expression. */
1838 sym
= e
->symtree
->n
.sym
;
1840 /* If the symbol is the function that names the current (or
1841 parent) scope, then we really have a variable reference. */
1843 if (gfc_is_function_return_value (sym
, sym
->ns
))
1846 /* If all else fails, see if we have a specific intrinsic. */
1847 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1849 gfc_intrinsic_sym
*isym
;
1851 isym
= gfc_find_function (sym
->name
);
1852 if (isym
== NULL
|| !isym
->specific
)
1854 gfc_error ("Unable to find a specific INTRINSIC procedure "
1855 "for the reference %qs at %L", sym
->name
,
1860 sym
->attr
.intrinsic
= 1;
1861 sym
->attr
.function
= 1;
1864 if (!gfc_resolve_expr (e
))
1869 /* See if the name is a module procedure in a parent unit. */
1871 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1874 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1876 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1880 if (parent_st
== NULL
)
1883 sym
= parent_st
->n
.sym
;
1884 e
->symtree
= parent_st
; /* Point to the right thing. */
1886 if (sym
->attr
.flavor
== FL_PROCEDURE
1887 || sym
->attr
.intrinsic
1888 || sym
->attr
.external
)
1890 if (!gfc_resolve_expr (e
))
1896 e
->expr_type
= EXPR_VARIABLE
;
1898 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1899 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1900 && CLASS_DATA (sym
)->as
))
1902 e
->rank
= sym
->ts
.type
== BT_CLASS
1903 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1904 e
->ref
= gfc_get_ref ();
1905 e
->ref
->type
= REF_ARRAY
;
1906 e
->ref
->u
.ar
.type
= AR_FULL
;
1907 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1908 ? CLASS_DATA (sym
)->as
: sym
->as
;
1911 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1912 primary.c (match_actual_arg). If above code determines that it
1913 is a variable instead, it needs to be resolved as it was not
1914 done at the beginning of this function. */
1915 save_need_full_assumed_size
= need_full_assumed_size
;
1916 if (e
->expr_type
!= EXPR_VARIABLE
)
1917 need_full_assumed_size
= 0;
1918 if (!gfc_resolve_expr (e
))
1920 need_full_assumed_size
= save_need_full_assumed_size
;
1923 /* Check argument list functions %VAL, %LOC and %REF. There is
1924 nothing to do for %REF. */
1925 if (arg
->name
&& arg
->name
[0] == '%')
1927 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1929 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1931 gfc_error ("By-value argument at %L is not of numeric "
1938 gfc_error ("By-value argument at %L cannot be an array or "
1939 "an array section", &e
->where
);
1943 /* Intrinsics are still PROC_UNKNOWN here. However,
1944 since same file external procedures are not resolvable
1945 in gfortran, it is a good deal easier to leave them to
1947 if (ptype
!= PROC_UNKNOWN
1948 && ptype
!= PROC_DUMMY
1949 && ptype
!= PROC_EXTERNAL
1950 && ptype
!= PROC_MODULE
)
1952 gfc_error ("By-value argument at %L is not allowed "
1953 "in this context", &e
->where
);
1958 /* Statement functions have already been excluded above. */
1959 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1960 && e
->ts
.type
== BT_PROCEDURE
)
1962 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1964 gfc_error ("Passing internal procedure at %L by location "
1965 "not allowed", &e
->where
);
1971 comp
= gfc_get_proc_ptr_comp(e
);
1972 if (comp
&& comp
->attr
.elemental
)
1974 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1975 "allowed as an actual argument at %L", comp
->name
,
1979 /* Fortran 2008, C1237. */
1980 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1981 && gfc_has_ultimate_pointer (e
))
1983 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1984 "component", &e
->where
);
1988 first_actual_arg
= false;
1991 return_value
= true;
1994 actual_arg
= actual_arg_sav
;
1995 first_actual_arg
= first_actual_arg_sav
;
1997 return return_value
;
2001 /* Do the checks of the actual argument list that are specific to elemental
2002 procedures. If called with c == NULL, we have a function, otherwise if
2003 expr == NULL, we have a subroutine. */
2006 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2008 gfc_actual_arglist
*arg0
;
2009 gfc_actual_arglist
*arg
;
2010 gfc_symbol
*esym
= NULL
;
2011 gfc_intrinsic_sym
*isym
= NULL
;
2013 gfc_intrinsic_arg
*iformal
= NULL
;
2014 gfc_formal_arglist
*eformal
= NULL
;
2015 bool formal_optional
= false;
2016 bool set_by_optional
= false;
2020 /* Is this an elemental procedure? */
2021 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2023 if (expr
->value
.function
.esym
!= NULL
2024 && expr
->value
.function
.esym
->attr
.elemental
)
2026 arg0
= expr
->value
.function
.actual
;
2027 esym
= expr
->value
.function
.esym
;
2029 else if (expr
->value
.function
.isym
!= NULL
2030 && expr
->value
.function
.isym
->elemental
)
2032 arg0
= expr
->value
.function
.actual
;
2033 isym
= expr
->value
.function
.isym
;
2038 else if (c
&& c
->ext
.actual
!= NULL
)
2040 arg0
= c
->ext
.actual
;
2042 if (c
->resolved_sym
)
2043 esym
= c
->resolved_sym
;
2045 esym
= c
->symtree
->n
.sym
;
2048 if (!esym
->attr
.elemental
)
2054 /* The rank of an elemental is the rank of its array argument(s). */
2055 for (arg
= arg0
; arg
; arg
= arg
->next
)
2057 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2059 rank
= arg
->expr
->rank
;
2060 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2061 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2062 set_by_optional
= true;
2064 /* Function specific; set the result rank and shape. */
2068 if (!expr
->shape
&& arg
->expr
->shape
)
2070 expr
->shape
= gfc_get_shape (rank
);
2071 for (i
= 0; i
< rank
; i
++)
2072 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2079 /* If it is an array, it shall not be supplied as an actual argument
2080 to an elemental procedure unless an array of the same rank is supplied
2081 as an actual argument corresponding to a nonoptional dummy argument of
2082 that elemental procedure(12.4.1.5). */
2083 formal_optional
= false;
2085 iformal
= isym
->formal
;
2087 eformal
= esym
->formal
;
2089 for (arg
= arg0
; arg
; arg
= arg
->next
)
2093 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2094 formal_optional
= true;
2095 eformal
= eformal
->next
;
2097 else if (isym
&& iformal
)
2099 if (iformal
->optional
)
2100 formal_optional
= true;
2101 iformal
= iformal
->next
;
2104 formal_optional
= true;
2106 if (pedantic
&& arg
->expr
!= NULL
2107 && arg
->expr
->expr_type
== EXPR_VARIABLE
2108 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2111 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2112 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2114 gfc_warning ("%qs at %L is an array and OPTIONAL; IF IT IS "
2115 "MISSING, it cannot be the actual argument of an "
2116 "ELEMENTAL procedure unless there is a non-optional "
2117 "argument with the same rank (12.4.1.5)",
2118 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2122 for (arg
= arg0
; arg
; arg
= arg
->next
)
2124 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2127 /* Being elemental, the last upper bound of an assumed size array
2128 argument must be present. */
2129 if (resolve_assumed_size_actual (arg
->expr
))
2132 /* Elemental procedure's array actual arguments must conform. */
2135 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2142 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2143 is an array, the intent inout/out variable needs to be also an array. */
2144 if (rank
> 0 && esym
&& expr
== NULL
)
2145 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2146 arg
= arg
->next
, eformal
= eformal
->next
)
2147 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2148 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2149 && arg
->expr
&& arg
->expr
->rank
== 0)
2151 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2152 "ELEMENTAL subroutine %qs is a scalar, but another "
2153 "actual argument is an array", &arg
->expr
->where
,
2154 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2155 : "INOUT", eformal
->sym
->name
, esym
->name
);
2162 /* This function does the checking of references to global procedures
2163 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2164 77 and 95 standards. It checks for a gsymbol for the name, making
2165 one if it does not already exist. If it already exists, then the
2166 reference being resolved must correspond to the type of gsymbol.
2167 Otherwise, the new symbol is equipped with the attributes of the
2168 reference. The corresponding code that is called in creating
2169 global entities is parse.c.
2171 In addition, for all but -std=legacy, the gsymbols are used to
2172 check the interfaces of external procedures from the same file.
2173 The namespace of the gsymbol is resolved and then, once this is
2174 done the interface is checked. */
2178 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2180 if (!gsym_ns
->proc_name
->attr
.recursive
)
2183 if (sym
->ns
== gsym_ns
)
2186 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2193 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2195 if (gsym_ns
->entries
)
2197 gfc_entry_list
*entry
= gsym_ns
->entries
;
2199 for (; entry
; entry
= entry
->next
)
2201 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2203 if (strcmp (gsym_ns
->proc_name
->name
,
2204 sym
->ns
->proc_name
->name
) == 0)
2208 && strcmp (gsym_ns
->proc_name
->name
,
2209 sym
->ns
->parent
->proc_name
->name
) == 0)
2218 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2221 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2223 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2225 for ( ; arg
; arg
= arg
->next
)
2230 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2232 strncpy (errmsg
, _("allocatable argument"), err_len
);
2235 else if (arg
->sym
->attr
.asynchronous
)
2237 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2240 else if (arg
->sym
->attr
.optional
)
2242 strncpy (errmsg
, _("optional argument"), err_len
);
2245 else if (arg
->sym
->attr
.pointer
)
2247 strncpy (errmsg
, _("pointer argument"), err_len
);
2250 else if (arg
->sym
->attr
.target
)
2252 strncpy (errmsg
, _("target argument"), err_len
);
2255 else if (arg
->sym
->attr
.value
)
2257 strncpy (errmsg
, _("value argument"), err_len
);
2260 else if (arg
->sym
->attr
.volatile_
)
2262 strncpy (errmsg
, _("volatile argument"), err_len
);
2265 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2267 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2270 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2272 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2275 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2277 strncpy (errmsg
, _("coarray argument"), err_len
);
2280 else if (false) /* (2d) TODO: parametrized derived type */
2282 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2285 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2287 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2290 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2292 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2295 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2297 /* As assumed-type is unlimited polymorphic (cf. above).
2298 See also TS 29113, Note 6.1. */
2299 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2304 if (sym
->attr
.function
)
2306 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2308 if (res
->attr
.dimension
) /* (3a) */
2310 strncpy (errmsg
, _("array result"), err_len
);
2313 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2315 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2318 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2319 && res
->ts
.u
.cl
->length
2320 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2322 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2327 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2329 strncpy (errmsg
, _("elemental procedure"), err_len
);
2332 else if (sym
->attr
.is_bind_c
) /* (5) */
2334 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2343 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2344 gfc_actual_arglist
**actual
, int sub
)
2348 enum gfc_symbol_type type
;
2351 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2353 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2355 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2356 gfc_global_used (gsym
, where
);
2358 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2359 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2360 && gsym
->type
!= GSYM_UNKNOWN
2361 && !gsym
->binding_label
2363 && gsym
->ns
->resolved
!= -1
2364 && gsym
->ns
->proc_name
2365 && not_in_recursive (sym
, gsym
->ns
)
2366 && not_entry_self_reference (sym
, gsym
->ns
))
2368 gfc_symbol
*def_sym
;
2370 /* Resolve the gsymbol namespace if needed. */
2371 if (!gsym
->ns
->resolved
)
2373 gfc_dt_list
*old_dt_list
;
2374 struct gfc_omp_saved_state old_omp_state
;
2376 /* Stash away derived types so that the backend_decls do not
2378 old_dt_list
= gfc_derived_types
;
2379 gfc_derived_types
= NULL
;
2380 /* And stash away openmp state. */
2381 gfc_omp_save_and_clear_state (&old_omp_state
);
2383 gfc_resolve (gsym
->ns
);
2385 /* Store the new derived types with the global namespace. */
2386 if (gfc_derived_types
)
2387 gsym
->ns
->derived_types
= gfc_derived_types
;
2389 /* Restore the derived types of this namespace. */
2390 gfc_derived_types
= old_dt_list
;
2391 /* And openmp state. */
2392 gfc_omp_restore_state (&old_omp_state
);
2395 /* Make sure that translation for the gsymbol occurs before
2396 the procedure currently being resolved. */
2397 ns
= gfc_global_ns_list
;
2398 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2400 if (ns
->sibling
== gsym
->ns
)
2402 ns
->sibling
= gsym
->ns
->sibling
;
2403 gsym
->ns
->sibling
= gfc_global_ns_list
;
2404 gfc_global_ns_list
= gsym
->ns
;
2409 def_sym
= gsym
->ns
->proc_name
;
2411 /* This can happen if a binding name has been specified. */
2412 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2413 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2415 if (def_sym
->attr
.entry_master
)
2417 gfc_entry_list
*entry
;
2418 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2419 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2421 def_sym
= entry
->sym
;
2426 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2428 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2429 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2430 gfc_typename (&def_sym
->ts
));
2434 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2435 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2437 gfc_error ("Explicit interface required for %qs at %L: %s",
2438 sym
->name
, &sym
->declared_at
, reason
);
2442 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2443 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2444 gfc_errors_to_warnings (true);
2446 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2447 reason
, sizeof(reason
), NULL
, NULL
))
2449 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2450 sym
->name
, &sym
->declared_at
, reason
);
2455 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2456 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2457 gfc_errors_to_warnings (true);
2459 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2460 gfc_procedure_use (def_sym
, actual
, where
);
2464 gfc_errors_to_warnings (false);
2466 if (gsym
->type
== GSYM_UNKNOWN
)
2469 gsym
->where
= *where
;
2476 /************* Function resolution *************/
2478 /* Resolve a function call known to be generic.
2479 Section 14.1.2.4.1. */
2482 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2486 if (sym
->attr
.generic
)
2488 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2491 expr
->value
.function
.name
= s
->name
;
2492 expr
->value
.function
.esym
= s
;
2494 if (s
->ts
.type
!= BT_UNKNOWN
)
2496 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2497 expr
->ts
= s
->result
->ts
;
2500 expr
->rank
= s
->as
->rank
;
2501 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2502 expr
->rank
= s
->result
->as
->rank
;
2504 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2509 /* TODO: Need to search for elemental references in generic
2513 if (sym
->attr
.intrinsic
)
2514 return gfc_intrinsic_func_interface (expr
, 0);
2521 resolve_generic_f (gfc_expr
*expr
)
2525 gfc_interface
*intr
= NULL
;
2527 sym
= expr
->symtree
->n
.sym
;
2531 m
= resolve_generic_f0 (expr
, sym
);
2534 else if (m
== MATCH_ERROR
)
2539 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2540 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2543 if (sym
->ns
->parent
== NULL
)
2545 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2549 if (!generic_sym (sym
))
2553 /* Last ditch attempt. See if the reference is to an intrinsic
2554 that possesses a matching interface. 14.1.2.4 */
2555 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2557 gfc_error ("There is no specific function for the generic %qs "
2558 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2564 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2567 return resolve_structure_cons (expr
, 0);
2570 m
= gfc_intrinsic_func_interface (expr
, 0);
2575 gfc_error ("Generic function %qs at %L is not consistent with a "
2576 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2583 /* Resolve a function call known to be specific. */
2586 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2590 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2592 if (sym
->attr
.dummy
)
2594 sym
->attr
.proc
= PROC_DUMMY
;
2598 sym
->attr
.proc
= PROC_EXTERNAL
;
2602 if (sym
->attr
.proc
== PROC_MODULE
2603 || sym
->attr
.proc
== PROC_ST_FUNCTION
2604 || sym
->attr
.proc
== PROC_INTERNAL
)
2607 if (sym
->attr
.intrinsic
)
2609 m
= gfc_intrinsic_func_interface (expr
, 1);
2613 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2614 "with an intrinsic", sym
->name
, &expr
->where
);
2622 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2625 expr
->ts
= sym
->result
->ts
;
2628 expr
->value
.function
.name
= sym
->name
;
2629 expr
->value
.function
.esym
= sym
;
2630 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2631 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2632 else if (sym
->as
!= NULL
)
2633 expr
->rank
= sym
->as
->rank
;
2640 resolve_specific_f (gfc_expr
*expr
)
2645 sym
= expr
->symtree
->n
.sym
;
2649 m
= resolve_specific_f0 (sym
, expr
);
2652 if (m
== MATCH_ERROR
)
2655 if (sym
->ns
->parent
== NULL
)
2658 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2664 gfc_error ("Unable to resolve the specific function %qs at %L",
2665 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2671 /* Resolve a procedure call not known to be generic nor specific. */
2674 resolve_unknown_f (gfc_expr
*expr
)
2679 sym
= expr
->symtree
->n
.sym
;
2681 if (sym
->attr
.dummy
)
2683 sym
->attr
.proc
= PROC_DUMMY
;
2684 expr
->value
.function
.name
= sym
->name
;
2688 /* See if we have an intrinsic function reference. */
2690 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2692 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2697 /* The reference is to an external name. */
2699 sym
->attr
.proc
= PROC_EXTERNAL
;
2700 expr
->value
.function
.name
= sym
->name
;
2701 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2703 if (sym
->as
!= NULL
)
2704 expr
->rank
= sym
->as
->rank
;
2706 /* Type of the expression is either the type of the symbol or the
2707 default type of the symbol. */
2710 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2712 if (sym
->ts
.type
!= BT_UNKNOWN
)
2716 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2718 if (ts
->type
== BT_UNKNOWN
)
2720 gfc_error ("Function %qs at %L has no IMPLICIT type",
2721 sym
->name
, &expr
->where
);
2732 /* Return true, if the symbol is an external procedure. */
2734 is_external_proc (gfc_symbol
*sym
)
2736 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2737 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2738 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2739 && !sym
->attr
.proc_pointer
2740 && !sym
->attr
.use_assoc
2748 /* Figure out if a function reference is pure or not. Also set the name
2749 of the function for a potential error message. Return nonzero if the
2750 function is PURE, zero if not. */
2752 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2755 pure_function (gfc_expr
*e
, const char **name
)
2758 gfc_component
*comp
;
2762 if (e
->symtree
!= NULL
2763 && e
->symtree
->n
.sym
!= NULL
2764 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2765 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2767 comp
= gfc_get_proc_ptr_comp (e
);
2770 pure
= gfc_pure (comp
->ts
.interface
);
2773 else if (e
->value
.function
.esym
)
2775 pure
= gfc_pure (e
->value
.function
.esym
);
2776 *name
= e
->value
.function
.esym
->name
;
2778 else if (e
->value
.function
.isym
)
2780 pure
= e
->value
.function
.isym
->pure
2781 || e
->value
.function
.isym
->elemental
;
2782 *name
= e
->value
.function
.isym
->name
;
2786 /* Implicit functions are not pure. */
2788 *name
= e
->value
.function
.name
;
2796 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2797 int *f ATTRIBUTE_UNUSED
)
2801 /* Don't bother recursing into other statement functions
2802 since they will be checked individually for purity. */
2803 if (e
->expr_type
!= EXPR_FUNCTION
2805 || e
->symtree
->n
.sym
== sym
2806 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2809 return pure_function (e
, &name
) ? false : true;
2814 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2816 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2820 /* Check if an impure function is allowed in the current context. */
2822 static bool check_pure_function (gfc_expr
*e
)
2824 const char *name
= NULL
;
2825 if (!pure_function (e
, &name
) && name
)
2829 gfc_error ("Reference to impure function %qs at %L inside a "
2830 "FORALL %s", name
, &e
->where
,
2831 forall_flag
== 2 ? "mask" : "block");
2834 else if (gfc_do_concurrent_flag
)
2836 gfc_error ("Reference to impure function %qs at %L inside a "
2837 "DO CONCURRENT %s", name
, &e
->where
,
2838 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2841 else if (gfc_pure (NULL
))
2843 gfc_error ("Reference to impure function %qs at %L "
2844 "within a PURE procedure", name
, &e
->where
);
2847 gfc_unset_implicit_pure (NULL
);
2853 /* Resolve a function call, which means resolving the arguments, then figuring
2854 out which entity the name refers to. */
2857 resolve_function (gfc_expr
*expr
)
2859 gfc_actual_arglist
*arg
;
2863 procedure_type p
= PROC_INTRINSIC
;
2864 bool no_formal_args
;
2868 sym
= expr
->symtree
->n
.sym
;
2870 /* If this is a procedure pointer component, it has already been resolved. */
2871 if (gfc_is_proc_ptr_comp (expr
))
2874 if (sym
&& sym
->attr
.intrinsic
2875 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2878 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2880 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2884 /* If this ia a deferred TBP with an abstract interface (which may
2885 of course be referenced), expr->value.function.esym will be set. */
2886 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2888 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2889 sym
->name
, &expr
->where
);
2893 /* Switch off assumed size checking and do this again for certain kinds
2894 of procedure, once the procedure itself is resolved. */
2895 need_full_assumed_size
++;
2897 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2898 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2900 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2901 inquiry_argument
= true;
2902 no_formal_args
= sym
&& is_external_proc (sym
)
2903 && gfc_sym_get_dummy_args (sym
) == NULL
;
2905 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2908 inquiry_argument
= false;
2912 inquiry_argument
= false;
2914 /* Resume assumed_size checking. */
2915 need_full_assumed_size
--;
2917 /* If the procedure is external, check for usage. */
2918 if (sym
&& is_external_proc (sym
))
2919 resolve_global_procedure (sym
, &expr
->where
,
2920 &expr
->value
.function
.actual
, 0);
2922 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2924 && sym
->ts
.u
.cl
->length
== NULL
2926 && !sym
->ts
.deferred
2927 && expr
->value
.function
.esym
== NULL
2928 && !sym
->attr
.contained
)
2930 /* Internal procedures are taken care of in resolve_contained_fntype. */
2931 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2932 "be used at %L since it is not a dummy argument",
2933 sym
->name
, &expr
->where
);
2937 /* See if function is already resolved. */
2939 if (expr
->value
.function
.name
!= NULL
2940 || expr
->value
.function
.isym
!= NULL
)
2942 if (expr
->ts
.type
== BT_UNKNOWN
)
2948 /* Apply the rules of section 14.1.2. */
2950 switch (procedure_kind (sym
))
2953 t
= resolve_generic_f (expr
);
2956 case PTYPE_SPECIFIC
:
2957 t
= resolve_specific_f (expr
);
2961 t
= resolve_unknown_f (expr
);
2965 gfc_internal_error ("resolve_function(): bad function type");
2969 /* If the expression is still a function (it might have simplified),
2970 then we check to see if we are calling an elemental function. */
2972 if (expr
->expr_type
!= EXPR_FUNCTION
)
2975 temp
= need_full_assumed_size
;
2976 need_full_assumed_size
= 0;
2978 if (!resolve_elemental_actual (expr
, NULL
))
2981 if (omp_workshare_flag
2982 && expr
->value
.function
.esym
2983 && ! gfc_elemental (expr
->value
.function
.esym
))
2985 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
2986 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2991 #define GENERIC_ID expr->value.function.isym->id
2992 else if (expr
->value
.function
.actual
!= NULL
2993 && expr
->value
.function
.isym
!= NULL
2994 && GENERIC_ID
!= GFC_ISYM_LBOUND
2995 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
2996 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
2997 && GENERIC_ID
!= GFC_ISYM_LEN
2998 && GENERIC_ID
!= GFC_ISYM_LOC
2999 && GENERIC_ID
!= GFC_ISYM_C_LOC
3000 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3002 /* Array intrinsics must also have the last upper bound of an
3003 assumed size array argument. UBOUND and SIZE have to be
3004 excluded from the check if the second argument is anything
3007 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3009 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3010 && arg
== expr
->value
.function
.actual
3011 && arg
->next
!= NULL
&& arg
->next
->expr
)
3013 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3016 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3019 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3024 if (arg
->expr
!= NULL
3025 && arg
->expr
->rank
> 0
3026 && resolve_assumed_size_actual (arg
->expr
))
3032 need_full_assumed_size
= temp
;
3034 if (!check_pure_function(expr
))
3037 /* Functions without the RECURSIVE attribution are not allowed to
3038 * call themselves. */
3039 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3042 esym
= expr
->value
.function
.esym
;
3044 if (is_illegal_recursion (esym
, gfc_current_ns
))
3046 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3047 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3048 " function %qs is not RECURSIVE",
3049 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3051 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3052 " is not RECURSIVE", esym
->name
, &expr
->where
);
3058 /* Character lengths of use associated functions may contains references to
3059 symbols not referenced from the current program unit otherwise. Make sure
3060 those symbols are marked as referenced. */
3062 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3063 && expr
->value
.function
.esym
->attr
.use_assoc
)
3065 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3068 /* Make sure that the expression has a typespec that works. */
3069 if (expr
->ts
.type
== BT_UNKNOWN
)
3071 if (expr
->symtree
->n
.sym
->result
3072 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3073 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3074 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3081 /************* Subroutine resolution *************/
3084 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3091 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3095 else if (gfc_do_concurrent_flag
)
3097 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3101 else if (gfc_pure (NULL
))
3103 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3107 gfc_unset_implicit_pure (NULL
);
3113 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3117 if (sym
->attr
.generic
)
3119 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3122 c
->resolved_sym
= s
;
3123 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3128 /* TODO: Need to search for elemental references in generic interface. */
3131 if (sym
->attr
.intrinsic
)
3132 return gfc_intrinsic_sub_interface (c
, 0);
3139 resolve_generic_s (gfc_code
*c
)
3144 sym
= c
->symtree
->n
.sym
;
3148 m
= resolve_generic_s0 (c
, sym
);
3151 else if (m
== MATCH_ERROR
)
3155 if (sym
->ns
->parent
== NULL
)
3157 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3161 if (!generic_sym (sym
))
3165 /* Last ditch attempt. See if the reference is to an intrinsic
3166 that possesses a matching interface. 14.1.2.4 */
3167 sym
= c
->symtree
->n
.sym
;
3169 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3171 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3172 sym
->name
, &c
->loc
);
3176 m
= gfc_intrinsic_sub_interface (c
, 0);
3180 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3181 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3187 /* Resolve a subroutine call known to be specific. */
3190 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3194 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3196 if (sym
->attr
.dummy
)
3198 sym
->attr
.proc
= PROC_DUMMY
;
3202 sym
->attr
.proc
= PROC_EXTERNAL
;
3206 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3209 if (sym
->attr
.intrinsic
)
3211 m
= gfc_intrinsic_sub_interface (c
, 1);
3215 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3216 "with an intrinsic", sym
->name
, &c
->loc
);
3224 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3226 c
->resolved_sym
= sym
;
3227 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3235 resolve_specific_s (gfc_code
*c
)
3240 sym
= c
->symtree
->n
.sym
;
3244 m
= resolve_specific_s0 (c
, sym
);
3247 if (m
== MATCH_ERROR
)
3250 if (sym
->ns
->parent
== NULL
)
3253 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3259 sym
= c
->symtree
->n
.sym
;
3260 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3261 sym
->name
, &c
->loc
);
3267 /* Resolve a subroutine call not known to be generic nor specific. */
3270 resolve_unknown_s (gfc_code
*c
)
3274 sym
= c
->symtree
->n
.sym
;
3276 if (sym
->attr
.dummy
)
3278 sym
->attr
.proc
= PROC_DUMMY
;
3282 /* See if we have an intrinsic function reference. */
3284 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3286 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3291 /* The reference is to an external name. */
3294 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3296 c
->resolved_sym
= sym
;
3298 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3302 /* Resolve a subroutine call. Although it was tempting to use the same code
3303 for functions, subroutines and functions are stored differently and this
3304 makes things awkward. */
3307 resolve_call (gfc_code
*c
)
3310 procedure_type ptype
= PROC_INTRINSIC
;
3311 gfc_symbol
*csym
, *sym
;
3312 bool no_formal_args
;
3314 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3316 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3318 gfc_error_1 ("'%s' at %L has a type, which is not consistent with "
3319 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3323 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3326 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3327 sym
= st
? st
->n
.sym
: NULL
;
3328 if (sym
&& csym
!= sym
3329 && sym
->ns
== gfc_current_ns
3330 && sym
->attr
.flavor
== FL_PROCEDURE
3331 && sym
->attr
.contained
)
3334 if (csym
->attr
.generic
)
3335 c
->symtree
->n
.sym
= sym
;
3338 csym
= c
->symtree
->n
.sym
;
3342 /* If this ia a deferred TBP, c->expr1 will be set. */
3343 if (!c
->expr1
&& csym
)
3345 if (csym
->attr
.abstract
)
3347 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3348 csym
->name
, &c
->loc
);
3352 /* Subroutines without the RECURSIVE attribution are not allowed to
3354 if (is_illegal_recursion (csym
, gfc_current_ns
))
3356 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3357 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3358 "as subroutine %qs is not RECURSIVE",
3359 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3361 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3362 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3368 /* Switch off assumed size checking and do this again for certain kinds
3369 of procedure, once the procedure itself is resolved. */
3370 need_full_assumed_size
++;
3373 ptype
= csym
->attr
.proc
;
3375 no_formal_args
= csym
&& is_external_proc (csym
)
3376 && gfc_sym_get_dummy_args (csym
) == NULL
;
3377 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3380 /* Resume assumed_size checking. */
3381 need_full_assumed_size
--;
3383 /* If external, check for usage. */
3384 if (csym
&& is_external_proc (csym
))
3385 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3388 if (c
->resolved_sym
== NULL
)
3390 c
->resolved_isym
= NULL
;
3391 switch (procedure_kind (csym
))
3394 t
= resolve_generic_s (c
);
3397 case PTYPE_SPECIFIC
:
3398 t
= resolve_specific_s (c
);
3402 t
= resolve_unknown_s (c
);
3406 gfc_internal_error ("resolve_subroutine(): bad function type");
3410 /* Some checks of elemental subroutine actual arguments. */
3411 if (!resolve_elemental_actual (NULL
, c
))
3418 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3419 op1->shape and op2->shape are non-NULL return true if their shapes
3420 match. If both op1->shape and op2->shape are non-NULL return false
3421 if their shapes do not match. If either op1->shape or op2->shape is
3422 NULL, return true. */
3425 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3432 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3434 for (i
= 0; i
< op1
->rank
; i
++)
3436 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3438 gfc_error_1 ("Shapes for operands at %L and %L are not conformable",
3439 &op1
->where
, &op2
->where
);
3450 /* Resolve an operator expression node. This can involve replacing the
3451 operation with a user defined function call. */
3454 resolve_operator (gfc_expr
*e
)
3456 gfc_expr
*op1
, *op2
;
3458 bool dual_locus_error
;
3461 /* Resolve all subnodes-- give them types. */
3463 switch (e
->value
.op
.op
)
3466 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3469 /* Fall through... */
3472 case INTRINSIC_UPLUS
:
3473 case INTRINSIC_UMINUS
:
3474 case INTRINSIC_PARENTHESES
:
3475 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3480 /* Typecheck the new node. */
3482 op1
= e
->value
.op
.op1
;
3483 op2
= e
->value
.op
.op2
;
3484 dual_locus_error
= false;
3486 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3487 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3489 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3493 switch (e
->value
.op
.op
)
3495 case INTRINSIC_UPLUS
:
3496 case INTRINSIC_UMINUS
:
3497 if (op1
->ts
.type
== BT_INTEGER
3498 || op1
->ts
.type
== BT_REAL
3499 || op1
->ts
.type
== BT_COMPLEX
)
3505 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3506 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3509 case INTRINSIC_PLUS
:
3510 case INTRINSIC_MINUS
:
3511 case INTRINSIC_TIMES
:
3512 case INTRINSIC_DIVIDE
:
3513 case INTRINSIC_POWER
:
3514 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3516 gfc_type_convert_binary (e
, 1);
3521 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3522 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3523 gfc_typename (&op2
->ts
));
3526 case INTRINSIC_CONCAT
:
3527 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3528 && op1
->ts
.kind
== op2
->ts
.kind
)
3530 e
->ts
.type
= BT_CHARACTER
;
3531 e
->ts
.kind
= op1
->ts
.kind
;
3536 _("Operands of string concatenation operator at %%L are %s/%s"),
3537 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3543 case INTRINSIC_NEQV
:
3544 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3546 e
->ts
.type
= BT_LOGICAL
;
3547 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3548 if (op1
->ts
.kind
< e
->ts
.kind
)
3549 gfc_convert_type (op1
, &e
->ts
, 2);
3550 else if (op2
->ts
.kind
< e
->ts
.kind
)
3551 gfc_convert_type (op2
, &e
->ts
, 2);
3555 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3556 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3557 gfc_typename (&op2
->ts
));
3562 if (op1
->ts
.type
== BT_LOGICAL
)
3564 e
->ts
.type
= BT_LOGICAL
;
3565 e
->ts
.kind
= op1
->ts
.kind
;
3569 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3570 gfc_typename (&op1
->ts
));
3574 case INTRINSIC_GT_OS
:
3576 case INTRINSIC_GE_OS
:
3578 case INTRINSIC_LT_OS
:
3580 case INTRINSIC_LE_OS
:
3581 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3583 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3587 /* Fall through... */
3590 case INTRINSIC_EQ_OS
:
3592 case INTRINSIC_NE_OS
:
3593 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3594 && op1
->ts
.kind
== op2
->ts
.kind
)
3596 e
->ts
.type
= BT_LOGICAL
;
3597 e
->ts
.kind
= gfc_default_logical_kind
;
3601 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3603 gfc_type_convert_binary (e
, 1);
3605 e
->ts
.type
= BT_LOGICAL
;
3606 e
->ts
.kind
= gfc_default_logical_kind
;
3608 if (warn_compare_reals
)
3610 gfc_intrinsic_op op
= e
->value
.op
.op
;
3612 /* Type conversion has made sure that the types of op1 and op2
3613 agree, so it is only necessary to check the first one. */
3614 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3615 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3616 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3620 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3621 msg
= "Equality comparison for %s at %L";
3623 msg
= "Inequality comparison for %s at %L";
3625 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3632 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3634 _("Logicals at %%L must be compared with %s instead of %s"),
3635 (e
->value
.op
.op
== INTRINSIC_EQ
3636 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3637 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3640 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3641 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3642 gfc_typename (&op2
->ts
));
3646 case INTRINSIC_USER
:
3647 if (e
->value
.op
.uop
->op
== NULL
)
3648 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3649 else if (op2
== NULL
)
3650 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3651 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3654 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3655 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3656 gfc_typename (&op2
->ts
));
3657 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3662 case INTRINSIC_PARENTHESES
:
3664 if (e
->ts
.type
== BT_CHARACTER
)
3665 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3669 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3672 /* Deal with arrayness of an operand through an operator. */
3676 switch (e
->value
.op
.op
)
3678 case INTRINSIC_PLUS
:
3679 case INTRINSIC_MINUS
:
3680 case INTRINSIC_TIMES
:
3681 case INTRINSIC_DIVIDE
:
3682 case INTRINSIC_POWER
:
3683 case INTRINSIC_CONCAT
:
3687 case INTRINSIC_NEQV
:
3689 case INTRINSIC_EQ_OS
:
3691 case INTRINSIC_NE_OS
:
3693 case INTRINSIC_GT_OS
:
3695 case INTRINSIC_GE_OS
:
3697 case INTRINSIC_LT_OS
:
3699 case INTRINSIC_LE_OS
:
3701 if (op1
->rank
== 0 && op2
->rank
== 0)
3704 if (op1
->rank
== 0 && op2
->rank
!= 0)
3706 e
->rank
= op2
->rank
;
3708 if (e
->shape
== NULL
)
3709 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3712 if (op1
->rank
!= 0 && op2
->rank
== 0)
3714 e
->rank
= op1
->rank
;
3716 if (e
->shape
== NULL
)
3717 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3720 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3722 if (op1
->rank
== op2
->rank
)
3724 e
->rank
= op1
->rank
;
3725 if (e
->shape
== NULL
)
3727 t
= compare_shapes (op1
, op2
);
3731 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3736 /* Allow higher level expressions to work. */
3739 /* Try user-defined operators, and otherwise throw an error. */
3740 dual_locus_error
= true;
3742 _("Inconsistent ranks for operator at %%L and %%L"));
3749 case INTRINSIC_PARENTHESES
:
3751 case INTRINSIC_UPLUS
:
3752 case INTRINSIC_UMINUS
:
3753 /* Simply copy arrayness attribute */
3754 e
->rank
= op1
->rank
;
3756 if (e
->shape
== NULL
)
3757 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3765 /* Attempt to simplify the expression. */
3768 t
= gfc_simplify_expr (e
, 0);
3769 /* Some calls do not succeed in simplification and return false
3770 even though there is no error; e.g. variable references to
3771 PARAMETER arrays. */
3772 if (!gfc_is_constant_expr (e
))
3780 match m
= gfc_extend_expr (e
);
3783 if (m
== MATCH_ERROR
)
3787 if (dual_locus_error
)
3788 gfc_error (msg
, &op1
->where
, &op2
->where
);
3790 gfc_error (msg
, &e
->where
);
3796 /************** Array resolution subroutines **************/
3799 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3802 /* Compare two integer expressions. */
3805 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3809 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3810 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3813 /* If either of the types isn't INTEGER, we must have
3814 raised an error earlier. */
3816 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3819 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3829 /* Compare an integer expression with an integer. */
3832 compare_bound_int (gfc_expr
*a
, int b
)
3836 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3839 if (a
->ts
.type
!= BT_INTEGER
)
3840 gfc_internal_error ("compare_bound_int(): Bad expression");
3842 i
= mpz_cmp_si (a
->value
.integer
, b
);
3852 /* Compare an integer expression with a mpz_t. */
3855 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3859 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3862 if (a
->ts
.type
!= BT_INTEGER
)
3863 gfc_internal_error ("compare_bound_int(): Bad expression");
3865 i
= mpz_cmp (a
->value
.integer
, b
);
3875 /* Compute the last value of a sequence given by a triplet.
3876 Return 0 if it wasn't able to compute the last value, or if the
3877 sequence if empty, and 1 otherwise. */
3880 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3881 gfc_expr
*stride
, mpz_t last
)
3885 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3886 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3887 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3890 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3891 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3894 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3896 if (compare_bound (start
, end
) == CMP_GT
)
3898 mpz_set (last
, end
->value
.integer
);
3902 if (compare_bound_int (stride
, 0) == CMP_GT
)
3904 /* Stride is positive */
3905 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3910 /* Stride is negative */
3911 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3916 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3917 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3918 mpz_sub (last
, end
->value
.integer
, rem
);
3925 /* Compare a single dimension of an array reference to the array
3929 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3933 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3935 gcc_assert (ar
->stride
[i
] == NULL
);
3936 /* This implies [*] as [*:] and [*:3] are not possible. */
3937 if (ar
->start
[i
] == NULL
)
3939 gcc_assert (ar
->end
[i
] == NULL
);
3944 /* Given start, end and stride values, calculate the minimum and
3945 maximum referenced indexes. */
3947 switch (ar
->dimen_type
[i
])
3950 case DIMEN_THIS_IMAGE
:
3955 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3958 gfc_warning ("Array reference at %L is out of bounds "
3959 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3960 mpz_get_si (ar
->start
[i
]->value
.integer
),
3961 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3963 gfc_warning ("Array reference at %L is out of bounds "
3964 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3965 mpz_get_si (ar
->start
[i
]->value
.integer
),
3966 mpz_get_si (as
->lower
[i
]->value
.integer
),
3970 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3973 gfc_warning ("Array reference at %L is out of bounds "
3974 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3975 mpz_get_si (ar
->start
[i
]->value
.integer
),
3976 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3978 gfc_warning ("Array reference at %L is out of bounds "
3979 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3980 mpz_get_si (ar
->start
[i
]->value
.integer
),
3981 mpz_get_si (as
->upper
[i
]->value
.integer
),
3990 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3991 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3993 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3995 /* Check for zero stride, which is not allowed. */
3996 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3998 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4002 /* if start == len || (stride > 0 && start < len)
4003 || (stride < 0 && start > len),
4004 then the array section contains at least one element. In this
4005 case, there is an out-of-bounds access if
4006 (start < lower || start > upper). */
4007 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4008 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4009 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4010 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4011 && comp_start_end
== CMP_GT
))
4013 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4015 gfc_warning ("Lower array reference at %L is out of bounds "
4016 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4017 mpz_get_si (AR_START
->value
.integer
),
4018 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4021 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4023 gfc_warning ("Lower array reference at %L is out of bounds "
4024 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4025 mpz_get_si (AR_START
->value
.integer
),
4026 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4031 /* If we can compute the highest index of the array section,
4032 then it also has to be between lower and upper. */
4033 mpz_init (last_value
);
4034 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4037 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4039 gfc_warning ("Upper array reference at %L is out of bounds "
4040 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4041 mpz_get_si (last_value
),
4042 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4043 mpz_clear (last_value
);
4046 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4048 gfc_warning ("Upper array reference at %L is out of bounds "
4049 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4050 mpz_get_si (last_value
),
4051 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4052 mpz_clear (last_value
);
4056 mpz_clear (last_value
);
4064 gfc_internal_error ("check_dimension(): Bad array reference");
4071 /* Compare an array reference with an array specification. */
4074 compare_spec_to_ref (gfc_array_ref
*ar
)
4081 /* TODO: Full array sections are only allowed as actual parameters. */
4082 if (as
->type
== AS_ASSUMED_SIZE
4083 && (/*ar->type == AR_FULL
4084 ||*/ (ar
->type
== AR_SECTION
4085 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4087 gfc_error ("Rightmost upper bound of assumed size array section "
4088 "not specified at %L", &ar
->where
);
4092 if (ar
->type
== AR_FULL
)
4095 if (as
->rank
!= ar
->dimen
)
4097 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4098 &ar
->where
, ar
->dimen
, as
->rank
);
4102 /* ar->codimen == 0 is a local array. */
4103 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4105 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4106 &ar
->where
, ar
->codimen
, as
->corank
);
4110 for (i
= 0; i
< as
->rank
; i
++)
4111 if (!check_dimension (i
, ar
, as
))
4114 /* Local access has no coarray spec. */
4115 if (ar
->codimen
!= 0)
4116 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4118 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4119 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4121 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4122 i
+ 1 - as
->rank
, &ar
->where
);
4125 if (!check_dimension (i
, ar
, as
))
4133 /* Resolve one part of an array index. */
4136 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4137 int force_index_integer_kind
)
4144 if (!gfc_resolve_expr (index
))
4147 if (check_scalar
&& index
->rank
!= 0)
4149 gfc_error ("Array index at %L must be scalar", &index
->where
);
4153 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4155 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4156 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4160 if (index
->ts
.type
== BT_REAL
)
4161 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4165 if ((index
->ts
.kind
!= gfc_index_integer_kind
4166 && force_index_integer_kind
)
4167 || index
->ts
.type
!= BT_INTEGER
)
4170 ts
.type
= BT_INTEGER
;
4171 ts
.kind
= gfc_index_integer_kind
;
4173 gfc_convert_type_warn (index
, &ts
, 2, 0);
4179 /* Resolve one part of an array index. */
4182 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4184 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4187 /* Resolve a dim argument to an intrinsic function. */
4190 gfc_resolve_dim_arg (gfc_expr
*dim
)
4195 if (!gfc_resolve_expr (dim
))
4200 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4205 if (dim
->ts
.type
!= BT_INTEGER
)
4207 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4211 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4216 ts
.type
= BT_INTEGER
;
4217 ts
.kind
= gfc_index_integer_kind
;
4219 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4225 /* Given an expression that contains array references, update those array
4226 references to point to the right array specifications. While this is
4227 filled in during matching, this information is difficult to save and load
4228 in a module, so we take care of it here.
4230 The idea here is that the original array reference comes from the
4231 base symbol. We traverse the list of reference structures, setting
4232 the stored reference to references. Component references can
4233 provide an additional array specification. */
4236 find_array_spec (gfc_expr
*e
)
4242 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4243 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4245 as
= e
->symtree
->n
.sym
->as
;
4247 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4252 gfc_internal_error ("find_array_spec(): Missing spec");
4259 c
= ref
->u
.c
.component
;
4260 if (c
->attr
.dimension
)
4263 gfc_internal_error ("find_array_spec(): unused as(1)");
4274 gfc_internal_error ("find_array_spec(): unused as(2)");
4278 /* Resolve an array reference. */
4281 resolve_array_ref (gfc_array_ref
*ar
)
4283 int i
, check_scalar
;
4286 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4288 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4290 /* Do not force gfc_index_integer_kind for the start. We can
4291 do fine with any integer kind. This avoids temporary arrays
4292 created for indexing with a vector. */
4293 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4295 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4297 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4302 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4306 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4310 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4311 if (e
->expr_type
== EXPR_VARIABLE
4312 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4313 ar
->start
[i
] = gfc_get_parentheses (e
);
4317 gfc_error ("Array index at %L is an array of rank %d",
4318 &ar
->c_where
[i
], e
->rank
);
4322 /* Fill in the upper bound, which may be lower than the
4323 specified one for something like a(2:10:5), which is
4324 identical to a(2:7:5). Only relevant for strides not equal
4325 to one. Don't try a division by zero. */
4326 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4327 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4328 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4329 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4333 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4335 if (ar
->end
[i
] == NULL
)
4338 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4340 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4342 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4343 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4345 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4356 if (ar
->type
== AR_FULL
)
4358 if (ar
->as
->rank
== 0)
4359 ar
->type
= AR_ELEMENT
;
4361 /* Make sure array is the same as array(:,:), this way
4362 we don't need to special case all the time. */
4363 ar
->dimen
= ar
->as
->rank
;
4364 for (i
= 0; i
< ar
->dimen
; i
++)
4366 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4368 gcc_assert (ar
->start
[i
] == NULL
);
4369 gcc_assert (ar
->end
[i
] == NULL
);
4370 gcc_assert (ar
->stride
[i
] == NULL
);
4374 /* If the reference type is unknown, figure out what kind it is. */
4376 if (ar
->type
== AR_UNKNOWN
)
4378 ar
->type
= AR_ELEMENT
;
4379 for (i
= 0; i
< ar
->dimen
; i
++)
4380 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4381 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4383 ar
->type
= AR_SECTION
;
4388 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4391 if (ar
->as
->corank
&& ar
->codimen
== 0)
4394 ar
->codimen
= ar
->as
->corank
;
4395 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4396 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4404 resolve_substring (gfc_ref
*ref
)
4406 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4408 if (ref
->u
.ss
.start
!= NULL
)
4410 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4413 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4415 gfc_error ("Substring start index at %L must be of type INTEGER",
4416 &ref
->u
.ss
.start
->where
);
4420 if (ref
->u
.ss
.start
->rank
!= 0)
4422 gfc_error ("Substring start index at %L must be scalar",
4423 &ref
->u
.ss
.start
->where
);
4427 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4428 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4429 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4431 gfc_error ("Substring start index at %L is less than one",
4432 &ref
->u
.ss
.start
->where
);
4437 if (ref
->u
.ss
.end
!= NULL
)
4439 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4442 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4444 gfc_error ("Substring end index at %L must be of type INTEGER",
4445 &ref
->u
.ss
.end
->where
);
4449 if (ref
->u
.ss
.end
->rank
!= 0)
4451 gfc_error ("Substring end index at %L must be scalar",
4452 &ref
->u
.ss
.end
->where
);
4456 if (ref
->u
.ss
.length
!= NULL
4457 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4458 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4459 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4461 gfc_error ("Substring end index at %L exceeds the string length",
4462 &ref
->u
.ss
.start
->where
);
4466 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4467 gfc_integer_kinds
[k
].huge
) == CMP_GT
4468 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4469 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4471 gfc_error ("Substring end index at %L is too large",
4472 &ref
->u
.ss
.end
->where
);
4481 /* This function supplies missing substring charlens. */
4484 gfc_resolve_substring_charlen (gfc_expr
*e
)
4487 gfc_expr
*start
, *end
;
4489 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4490 if (char_ref
->type
== REF_SUBSTRING
)
4496 gcc_assert (char_ref
->next
== NULL
);
4500 if (e
->ts
.u
.cl
->length
)
4501 gfc_free_expr (e
->ts
.u
.cl
->length
);
4502 else if (e
->expr_type
== EXPR_VARIABLE
4503 && e
->symtree
->n
.sym
->attr
.dummy
)
4507 e
->ts
.type
= BT_CHARACTER
;
4508 e
->ts
.kind
= gfc_default_character_kind
;
4511 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4513 if (char_ref
->u
.ss
.start
)
4514 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4516 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4518 if (char_ref
->u
.ss
.end
)
4519 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4520 else if (e
->expr_type
== EXPR_VARIABLE
)
4521 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4527 gfc_free_expr (start
);
4528 gfc_free_expr (end
);
4532 /* Length = (end - start +1). */
4533 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4534 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4535 gfc_get_int_expr (gfc_default_integer_kind
,
4538 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4539 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4541 /* Make sure that the length is simplified. */
4542 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4543 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4547 /* Resolve subtype references. */
4550 resolve_ref (gfc_expr
*expr
)
4552 int current_part_dimension
, n_components
, seen_part_dimension
;
4555 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4556 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4558 find_array_spec (expr
);
4562 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4566 if (!resolve_array_ref (&ref
->u
.ar
))
4574 if (!resolve_substring (ref
))
4579 /* Check constraints on part references. */
4581 current_part_dimension
= 0;
4582 seen_part_dimension
= 0;
4585 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4590 switch (ref
->u
.ar
.type
)
4593 /* Coarray scalar. */
4594 if (ref
->u
.ar
.as
->rank
== 0)
4596 current_part_dimension
= 0;
4601 current_part_dimension
= 1;
4605 current_part_dimension
= 0;
4609 gfc_internal_error ("resolve_ref(): Bad array reference");
4615 if (current_part_dimension
|| seen_part_dimension
)
4618 if (ref
->u
.c
.component
->attr
.pointer
4619 || ref
->u
.c
.component
->attr
.proc_pointer
4620 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4621 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4623 gfc_error ("Component to the right of a part reference "
4624 "with nonzero rank must not have the POINTER "
4625 "attribute at %L", &expr
->where
);
4628 else if (ref
->u
.c
.component
->attr
.allocatable
4629 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4630 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4633 gfc_error ("Component to the right of a part reference "
4634 "with nonzero rank must not have the ALLOCATABLE "
4635 "attribute at %L", &expr
->where
);
4647 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4648 || ref
->next
== NULL
)
4649 && current_part_dimension
4650 && seen_part_dimension
)
4652 gfc_error ("Two or more part references with nonzero rank must "
4653 "not be specified at %L", &expr
->where
);
4657 if (ref
->type
== REF_COMPONENT
)
4659 if (current_part_dimension
)
4660 seen_part_dimension
= 1;
4662 /* reset to make sure */
4663 current_part_dimension
= 0;
4671 /* Given an expression, determine its shape. This is easier than it sounds.
4672 Leaves the shape array NULL if it is not possible to determine the shape. */
4675 expression_shape (gfc_expr
*e
)
4677 mpz_t array
[GFC_MAX_DIMENSIONS
];
4680 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4683 for (i
= 0; i
< e
->rank
; i
++)
4684 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4687 e
->shape
= gfc_get_shape (e
->rank
);
4689 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4694 for (i
--; i
>= 0; i
--)
4695 mpz_clear (array
[i
]);
4699 /* Given a variable expression node, compute the rank of the expression by
4700 examining the base symbol and any reference structures it may have. */
4703 expression_rank (gfc_expr
*e
)
4708 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4709 could lead to serious confusion... */
4710 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4714 if (e
->expr_type
== EXPR_ARRAY
)
4716 /* Constructors can have a rank different from one via RESHAPE(). */
4718 if (e
->symtree
== NULL
)
4724 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4725 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4731 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4733 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4734 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4735 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4737 if (ref
->type
!= REF_ARRAY
)
4740 if (ref
->u
.ar
.type
== AR_FULL
)
4742 rank
= ref
->u
.ar
.as
->rank
;
4746 if (ref
->u
.ar
.type
== AR_SECTION
)
4748 /* Figure out the rank of the section. */
4750 gfc_internal_error ("expression_rank(): Two array specs");
4752 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4753 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4754 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4764 expression_shape (e
);
4769 add_caf_get_intrinsic (gfc_expr
*e
)
4771 gfc_expr
*wrapper
, *tmp_expr
;
4775 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4776 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4781 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4782 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4785 tmp_expr
= XCNEW (gfc_expr
);
4787 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4788 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4789 wrapper
->ts
= e
->ts
;
4790 wrapper
->rank
= e
->rank
;
4792 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4799 remove_caf_get_intrinsic (gfc_expr
*e
)
4801 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4802 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4803 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4804 e
->value
.function
.actual
->expr
= NULL
;
4805 gfc_free_actual_arglist (e
->value
.function
.actual
);
4806 gfc_free_shape (&e
->shape
, e
->rank
);
4812 /* Resolve a variable expression. */
4815 resolve_variable (gfc_expr
*e
)
4822 if (e
->symtree
== NULL
)
4824 sym
= e
->symtree
->n
.sym
;
4826 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4827 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4828 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4830 if (!actual_arg
|| inquiry_argument
)
4832 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4833 "be used as actual argument", sym
->name
, &e
->where
);
4837 /* TS 29113, 407b. */
4838 else if (e
->ts
.type
== BT_ASSUMED
)
4842 gfc_error ("Assumed-type variable %s at %L may only be used "
4843 "as actual argument", sym
->name
, &e
->where
);
4846 else if (inquiry_argument
&& !first_actual_arg
)
4848 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4849 for all inquiry functions in resolve_function; the reason is
4850 that the function-name resolution happens too late in that
4852 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4853 "an inquiry function shall be the first argument",
4854 sym
->name
, &e
->where
);
4858 /* TS 29113, C535b. */
4859 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4860 && CLASS_DATA (sym
)->as
4861 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4862 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4863 && sym
->as
->type
== AS_ASSUMED_RANK
))
4867 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4868 "actual argument", sym
->name
, &e
->where
);
4871 else if (inquiry_argument
&& !first_actual_arg
)
4873 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4874 for all inquiry functions in resolve_function; the reason is
4875 that the function-name resolution happens too late in that
4877 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4878 "to an inquiry function shall be the first argument",
4879 sym
->name
, &e
->where
);
4884 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4885 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4886 && e
->ref
->next
== NULL
))
4888 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4889 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4892 /* TS 29113, 407b. */
4893 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4894 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4895 && e
->ref
->next
== NULL
))
4897 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4898 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4902 /* TS 29113, C535b. */
4903 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4904 && CLASS_DATA (sym
)->as
4905 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4906 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4907 && sym
->as
->type
== AS_ASSUMED_RANK
))
4909 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4910 && e
->ref
->next
== NULL
))
4912 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4913 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4918 /* If this is an associate-name, it may be parsed with an array reference
4919 in error even though the target is scalar. Fail directly in this case.
4920 TODO Understand why class scalar expressions must be excluded. */
4921 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4923 if (sym
->ts
.type
== BT_CLASS
)
4924 gfc_fix_class_refs (e
);
4925 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4929 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4930 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4932 /* On the other hand, the parser may not have known this is an array;
4933 in this case, we have to add a FULL reference. */
4934 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4936 e
->ref
= gfc_get_ref ();
4937 e
->ref
->type
= REF_ARRAY
;
4938 e
->ref
->u
.ar
.type
= AR_FULL
;
4939 e
->ref
->u
.ar
.dimen
= 0;
4942 if (e
->ref
&& !resolve_ref (e
))
4945 if (sym
->attr
.flavor
== FL_PROCEDURE
4946 && (!sym
->attr
.function
4947 || (sym
->attr
.function
&& sym
->result
4948 && sym
->result
->attr
.proc_pointer
4949 && !sym
->result
->attr
.function
)))
4951 e
->ts
.type
= BT_PROCEDURE
;
4952 goto resolve_procedure
;
4955 if (sym
->ts
.type
!= BT_UNKNOWN
)
4956 gfc_variable_attr (e
, &e
->ts
);
4959 /* Must be a simple variable reference. */
4960 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4965 if (check_assumed_size_reference (sym
, e
))
4968 /* Deal with forward references to entries during gfc_resolve_code, to
4969 satisfy, at least partially, 12.5.2.5. */
4970 if (gfc_current_ns
->entries
4971 && current_entry_id
== sym
->entry_id
4974 && cs_base
->current
->op
!= EXEC_ENTRY
)
4976 gfc_entry_list
*entry
;
4977 gfc_formal_arglist
*formal
;
4979 bool seen
, saved_specification_expr
;
4981 /* If the symbol is a dummy... */
4982 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4984 entry
= gfc_current_ns
->entries
;
4987 /* ...test if the symbol is a parameter of previous entries. */
4988 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4989 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4991 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4998 /* If it has not been seen as a dummy, this is an error. */
5001 if (specification_expr
)
5002 gfc_error ("Variable %qs, used in a specification expression"
5003 ", is referenced at %L before the ENTRY statement "
5004 "in which it is a parameter",
5005 sym
->name
, &cs_base
->current
->loc
);
5007 gfc_error ("Variable %qs is used at %L before the ENTRY "
5008 "statement in which it is a parameter",
5009 sym
->name
, &cs_base
->current
->loc
);
5014 /* Now do the same check on the specification expressions. */
5015 saved_specification_expr
= specification_expr
;
5016 specification_expr
= true;
5017 if (sym
->ts
.type
== BT_CHARACTER
5018 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5022 for (n
= 0; n
< sym
->as
->rank
; n
++)
5024 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5026 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5029 specification_expr
= saved_specification_expr
;
5032 /* Update the symbol's entry level. */
5033 sym
->entry_id
= current_entry_id
+ 1;
5036 /* If a symbol has been host_associated mark it. This is used latter,
5037 to identify if aliasing is possible via host association. */
5038 if (sym
->attr
.flavor
== FL_VARIABLE
5039 && gfc_current_ns
->parent
5040 && (gfc_current_ns
->parent
== sym
->ns
5041 || (gfc_current_ns
->parent
->parent
5042 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5043 sym
->attr
.host_assoc
= 1;
5046 if (t
&& !resolve_procedure_expression (e
))
5049 /* F2008, C617 and C1229. */
5050 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5051 && gfc_is_coindexed (e
))
5053 gfc_ref
*ref
, *ref2
= NULL
;
5055 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5057 if (ref
->type
== REF_COMPONENT
)
5059 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5063 for ( ; ref
; ref
= ref
->next
)
5064 if (ref
->type
== REF_COMPONENT
)
5067 /* Expression itself is not coindexed object. */
5068 if (ref
&& e
->ts
.type
== BT_CLASS
)
5070 gfc_error ("Polymorphic subobject of coindexed object at %L",
5075 /* Expression itself is coindexed object. */
5079 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5080 for ( ; c
; c
= c
->next
)
5081 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5083 gfc_error ("Coindexed object with polymorphic allocatable "
5084 "subcomponent at %L", &e
->where
);
5092 expression_rank (e
);
5094 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5095 add_caf_get_intrinsic (e
);
5101 /* Checks to see that the correct symbol has been host associated.
5102 The only situation where this arises is that in which a twice
5103 contained function is parsed after the host association is made.
5104 Therefore, on detecting this, change the symbol in the expression
5105 and convert the array reference into an actual arglist if the old
5106 symbol is a variable. */
5108 check_host_association (gfc_expr
*e
)
5110 gfc_symbol
*sym
, *old_sym
;
5114 gfc_actual_arglist
*arg
, *tail
= NULL
;
5115 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5117 /* If the expression is the result of substitution in
5118 interface.c(gfc_extend_expr) because there is no way in
5119 which the host association can be wrong. */
5120 if (e
->symtree
== NULL
5121 || e
->symtree
->n
.sym
== NULL
5122 || e
->user_operator
)
5125 old_sym
= e
->symtree
->n
.sym
;
5127 if (gfc_current_ns
->parent
5128 && old_sym
->ns
!= gfc_current_ns
)
5130 /* Use the 'USE' name so that renamed module symbols are
5131 correctly handled. */
5132 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5134 if (sym
&& old_sym
!= sym
5135 && sym
->ts
.type
== old_sym
->ts
.type
5136 && sym
->attr
.flavor
== FL_PROCEDURE
5137 && sym
->attr
.contained
)
5139 /* Clear the shape, since it might not be valid. */
5140 gfc_free_shape (&e
->shape
, e
->rank
);
5142 /* Give the expression the right symtree! */
5143 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5144 gcc_assert (st
!= NULL
);
5146 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5147 || e
->expr_type
== EXPR_FUNCTION
)
5149 /* Original was function so point to the new symbol, since
5150 the actual argument list is already attached to the
5152 e
->value
.function
.esym
= NULL
;
5157 /* Original was variable so convert array references into
5158 an actual arglist. This does not need any checking now
5159 since resolve_function will take care of it. */
5160 e
->value
.function
.actual
= NULL
;
5161 e
->expr_type
= EXPR_FUNCTION
;
5164 /* Ambiguity will not arise if the array reference is not
5165 the last reference. */
5166 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5167 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5170 gcc_assert (ref
->type
== REF_ARRAY
);
5172 /* Grab the start expressions from the array ref and
5173 copy them into actual arguments. */
5174 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5176 arg
= gfc_get_actual_arglist ();
5177 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5178 if (e
->value
.function
.actual
== NULL
)
5179 tail
= e
->value
.function
.actual
= arg
;
5187 /* Dump the reference list and set the rank. */
5188 gfc_free_ref_list (e
->ref
);
5190 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5193 gfc_resolve_expr (e
);
5197 /* This might have changed! */
5198 return e
->expr_type
== EXPR_FUNCTION
;
5203 gfc_resolve_character_operator (gfc_expr
*e
)
5205 gfc_expr
*op1
= e
->value
.op
.op1
;
5206 gfc_expr
*op2
= e
->value
.op
.op2
;
5207 gfc_expr
*e1
= NULL
;
5208 gfc_expr
*e2
= NULL
;
5210 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5212 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5213 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5214 else if (op1
->expr_type
== EXPR_CONSTANT
)
5215 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5216 op1
->value
.character
.length
);
5218 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5219 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5220 else if (op2
->expr_type
== EXPR_CONSTANT
)
5221 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5222 op2
->value
.character
.length
);
5224 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5234 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5235 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5236 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5237 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5238 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5244 /* Ensure that an character expression has a charlen and, if possible, a
5245 length expression. */
5248 fixup_charlen (gfc_expr
*e
)
5250 /* The cases fall through so that changes in expression type and the need
5251 for multiple fixes are picked up. In all circumstances, a charlen should
5252 be available for the middle end to hang a backend_decl on. */
5253 switch (e
->expr_type
)
5256 gfc_resolve_character_operator (e
);
5259 if (e
->expr_type
== EXPR_ARRAY
)
5260 gfc_resolve_character_array_constructor (e
);
5262 case EXPR_SUBSTRING
:
5263 if (!e
->ts
.u
.cl
&& e
->ref
)
5264 gfc_resolve_substring_charlen (e
);
5268 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5275 /* Update an actual argument to include the passed-object for type-bound
5276 procedures at the right position. */
5278 static gfc_actual_arglist
*
5279 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5282 gcc_assert (argpos
> 0);
5286 gfc_actual_arglist
* result
;
5288 result
= gfc_get_actual_arglist ();
5292 result
->name
= name
;
5298 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5300 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5305 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5308 extract_compcall_passed_object (gfc_expr
* e
)
5312 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5314 if (e
->value
.compcall
.base_object
)
5315 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5318 po
= gfc_get_expr ();
5319 po
->expr_type
= EXPR_VARIABLE
;
5320 po
->symtree
= e
->symtree
;
5321 po
->ref
= gfc_copy_ref (e
->ref
);
5322 po
->where
= e
->where
;
5325 if (!gfc_resolve_expr (po
))
5332 /* Update the arglist of an EXPR_COMPCALL expression to include the
5336 update_compcall_arglist (gfc_expr
* e
)
5339 gfc_typebound_proc
* tbp
;
5341 tbp
= e
->value
.compcall
.tbp
;
5346 po
= extract_compcall_passed_object (e
);
5350 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5356 gcc_assert (tbp
->pass_arg_num
> 0);
5357 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5365 /* Extract the passed object from a PPC call (a copy of it). */
5368 extract_ppc_passed_object (gfc_expr
*e
)
5373 po
= gfc_get_expr ();
5374 po
->expr_type
= EXPR_VARIABLE
;
5375 po
->symtree
= e
->symtree
;
5376 po
->ref
= gfc_copy_ref (e
->ref
);
5377 po
->where
= e
->where
;
5379 /* Remove PPC reference. */
5381 while ((*ref
)->next
)
5382 ref
= &(*ref
)->next
;
5383 gfc_free_ref_list (*ref
);
5386 if (!gfc_resolve_expr (po
))
5393 /* Update the actual arglist of a procedure pointer component to include the
5397 update_ppc_arglist (gfc_expr
* e
)
5401 gfc_typebound_proc
* tb
;
5403 ppc
= gfc_get_proc_ptr_comp (e
);
5411 else if (tb
->nopass
)
5414 po
= extract_ppc_passed_object (e
);
5421 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5426 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5428 gfc_error ("Base object for procedure-pointer component call at %L is of"
5429 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5433 gcc_assert (tb
->pass_arg_num
> 0);
5434 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5442 /* Check that the object a TBP is called on is valid, i.e. it must not be
5443 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5446 check_typebound_baseobject (gfc_expr
* e
)
5449 bool return_value
= false;
5451 base
= extract_compcall_passed_object (e
);
5455 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5457 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5461 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5463 gfc_error ("Base object for type-bound procedure call at %L is of"
5464 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5468 /* F08:C1230. If the procedure called is NOPASS,
5469 the base object must be scalar. */
5470 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5472 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5473 " be scalar", &e
->where
);
5477 return_value
= true;
5480 gfc_free_expr (base
);
5481 return return_value
;
5485 /* Resolve a call to a type-bound procedure, either function or subroutine,
5486 statically from the data in an EXPR_COMPCALL expression. The adapted
5487 arglist and the target-procedure symtree are returned. */
5490 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5491 gfc_actual_arglist
** actual
)
5493 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5494 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5496 /* Update the actual arglist for PASS. */
5497 if (!update_compcall_arglist (e
))
5500 *actual
= e
->value
.compcall
.actual
;
5501 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5503 gfc_free_ref_list (e
->ref
);
5505 e
->value
.compcall
.actual
= NULL
;
5507 /* If we find a deferred typebound procedure, check for derived types
5508 that an overriding typebound procedure has not been missed. */
5509 if (e
->value
.compcall
.name
5510 && !e
->value
.compcall
.tbp
->non_overridable
5511 && e
->value
.compcall
.base_object
5512 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5515 gfc_symbol
*derived
;
5517 /* Use the derived type of the base_object. */
5518 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5521 /* If necessary, go through the inheritance chain. */
5522 while (!st
&& derived
)
5524 /* Look for the typebound procedure 'name'. */
5525 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5526 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5527 e
->value
.compcall
.name
);
5529 derived
= gfc_get_derived_super_type (derived
);
5532 /* Now find the specific name in the derived type namespace. */
5533 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5534 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5535 derived
->ns
, 1, &st
);
5543 /* Get the ultimate declared type from an expression. In addition,
5544 return the last class/derived type reference and the copy of the
5545 reference list. If check_types is set true, derived types are
5546 identified as well as class references. */
5548 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5549 gfc_expr
*e
, bool check_types
)
5551 gfc_symbol
*declared
;
5558 *new_ref
= gfc_copy_ref (e
->ref
);
5560 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5562 if (ref
->type
!= REF_COMPONENT
)
5565 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5566 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5567 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5569 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5575 if (declared
== NULL
)
5576 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5582 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5583 which of the specific bindings (if any) matches the arglist and transform
5584 the expression into a call of that binding. */
5587 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5589 gfc_typebound_proc
* genproc
;
5590 const char* genname
;
5592 gfc_symbol
*derived
;
5594 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5595 genname
= e
->value
.compcall
.name
;
5596 genproc
= e
->value
.compcall
.tbp
;
5598 if (!genproc
->is_generic
)
5601 /* Try the bindings on this type and in the inheritance hierarchy. */
5602 for (; genproc
; genproc
= genproc
->overridden
)
5606 gcc_assert (genproc
->is_generic
);
5607 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5610 gfc_actual_arglist
* args
;
5613 gcc_assert (g
->specific
);
5615 if (g
->specific
->error
)
5618 target
= g
->specific
->u
.specific
->n
.sym
;
5620 /* Get the right arglist by handling PASS/NOPASS. */
5621 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5622 if (!g
->specific
->nopass
)
5625 po
= extract_compcall_passed_object (e
);
5628 gfc_free_actual_arglist (args
);
5632 gcc_assert (g
->specific
->pass_arg_num
> 0);
5633 gcc_assert (!g
->specific
->error
);
5634 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5635 g
->specific
->pass_arg
);
5637 resolve_actual_arglist (args
, target
->attr
.proc
,
5638 is_external_proc (target
)
5639 && gfc_sym_get_dummy_args (target
) == NULL
);
5641 /* Check if this arglist matches the formal. */
5642 matches
= gfc_arglist_matches_symbol (&args
, target
);
5644 /* Clean up and break out of the loop if we've found it. */
5645 gfc_free_actual_arglist (args
);
5648 e
->value
.compcall
.tbp
= g
->specific
;
5649 genname
= g
->specific_st
->name
;
5650 /* Pass along the name for CLASS methods, where the vtab
5651 procedure pointer component has to be referenced. */
5659 /* Nothing matching found! */
5660 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5661 " %qs at %L", genname
, &e
->where
);
5665 /* Make sure that we have the right specific instance for the name. */
5666 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5668 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5670 e
->value
.compcall
.tbp
= st
->n
.tb
;
5676 /* Resolve a call to a type-bound subroutine. */
5679 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5681 gfc_actual_arglist
* newactual
;
5682 gfc_symtree
* target
;
5684 /* Check that's really a SUBROUTINE. */
5685 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5687 gfc_error ("%qs at %L should be a SUBROUTINE",
5688 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5692 if (!check_typebound_baseobject (c
->expr1
))
5695 /* Pass along the name for CLASS methods, where the vtab
5696 procedure pointer component has to be referenced. */
5698 *name
= c
->expr1
->value
.compcall
.name
;
5700 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5703 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5705 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5707 /* Transform into an ordinary EXEC_CALL for now. */
5709 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5712 c
->ext
.actual
= newactual
;
5713 c
->symtree
= target
;
5714 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5716 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5718 gfc_free_expr (c
->expr1
);
5719 c
->expr1
= gfc_get_expr ();
5720 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5721 c
->expr1
->symtree
= target
;
5722 c
->expr1
->where
= c
->loc
;
5724 return resolve_call (c
);
5728 /* Resolve a component-call expression. */
5730 resolve_compcall (gfc_expr
* e
, const char **name
)
5732 gfc_actual_arglist
* newactual
;
5733 gfc_symtree
* target
;
5735 /* Check that's really a FUNCTION. */
5736 if (!e
->value
.compcall
.tbp
->function
)
5738 gfc_error ("%qs at %L should be a FUNCTION",
5739 e
->value
.compcall
.name
, &e
->where
);
5743 /* These must not be assign-calls! */
5744 gcc_assert (!e
->value
.compcall
.assign
);
5746 if (!check_typebound_baseobject (e
))
5749 /* Pass along the name for CLASS methods, where the vtab
5750 procedure pointer component has to be referenced. */
5752 *name
= e
->value
.compcall
.name
;
5754 if (!resolve_typebound_generic_call (e
, name
))
5756 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5758 /* Take the rank from the function's symbol. */
5759 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5760 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5762 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5763 arglist to the TBP's binding target. */
5765 if (!resolve_typebound_static (e
, &target
, &newactual
))
5768 e
->value
.function
.actual
= newactual
;
5769 e
->value
.function
.name
= NULL
;
5770 e
->value
.function
.esym
= target
->n
.sym
;
5771 e
->value
.function
.isym
= NULL
;
5772 e
->symtree
= target
;
5773 e
->ts
= target
->n
.sym
->ts
;
5774 e
->expr_type
= EXPR_FUNCTION
;
5776 /* Resolution is not necessary if this is a class subroutine; this
5777 function only has to identify the specific proc. Resolution of
5778 the call will be done next in resolve_typebound_call. */
5779 return gfc_resolve_expr (e
);
5783 static bool resolve_fl_derived (gfc_symbol
*sym
);
5786 /* Resolve a typebound function, or 'method'. First separate all
5787 the non-CLASS references by calling resolve_compcall directly. */
5790 resolve_typebound_function (gfc_expr
* e
)
5792 gfc_symbol
*declared
;
5804 /* Deal with typebound operators for CLASS objects. */
5805 expr
= e
->value
.compcall
.base_object
;
5806 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5807 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5809 /* If the base_object is not a variable, the corresponding actual
5810 argument expression must be stored in e->base_expression so
5811 that the corresponding tree temporary can be used as the base
5812 object in gfc_conv_procedure_call. */
5813 if (expr
->expr_type
!= EXPR_VARIABLE
)
5815 gfc_actual_arglist
*args
;
5817 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5819 if (expr
== args
->expr
)
5824 /* Since the typebound operators are generic, we have to ensure
5825 that any delays in resolution are corrected and that the vtab
5828 declared
= ts
.u
.derived
;
5829 c
= gfc_find_component (declared
, "_vptr", true, true);
5830 if (c
->ts
.u
.derived
== NULL
)
5831 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5833 if (!resolve_compcall (e
, &name
))
5836 /* Use the generic name if it is there. */
5837 name
= name
? name
: e
->value
.function
.esym
->name
;
5838 e
->symtree
= expr
->symtree
;
5839 e
->ref
= gfc_copy_ref (expr
->ref
);
5840 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5842 /* Trim away the extraneous references that emerge from nested
5843 use of interface.c (extend_expr). */
5844 if (class_ref
&& class_ref
->next
)
5846 gfc_free_ref_list (class_ref
->next
);
5847 class_ref
->next
= NULL
;
5849 else if (e
->ref
&& !class_ref
)
5851 gfc_free_ref_list (e
->ref
);
5855 gfc_add_vptr_component (e
);
5856 gfc_add_component_ref (e
, name
);
5857 e
->value
.function
.esym
= NULL
;
5858 if (expr
->expr_type
!= EXPR_VARIABLE
)
5859 e
->base_expr
= expr
;
5864 return resolve_compcall (e
, NULL
);
5866 if (!resolve_ref (e
))
5869 /* Get the CLASS declared type. */
5870 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5872 if (!resolve_fl_derived (declared
))
5875 /* Weed out cases of the ultimate component being a derived type. */
5876 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5877 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5879 gfc_free_ref_list (new_ref
);
5880 return resolve_compcall (e
, NULL
);
5883 c
= gfc_find_component (declared
, "_data", true, true);
5884 declared
= c
->ts
.u
.derived
;
5886 /* Treat the call as if it is a typebound procedure, in order to roll
5887 out the correct name for the specific function. */
5888 if (!resolve_compcall (e
, &name
))
5890 gfc_free_ref_list (new_ref
);
5897 /* Convert the expression to a procedure pointer component call. */
5898 e
->value
.function
.esym
= NULL
;
5904 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5905 gfc_add_vptr_component (e
);
5906 gfc_add_component_ref (e
, name
);
5908 /* Recover the typespec for the expression. This is really only
5909 necessary for generic procedures, where the additional call
5910 to gfc_add_component_ref seems to throw the collection of the
5911 correct typespec. */
5915 gfc_free_ref_list (new_ref
);
5920 /* Resolve a typebound subroutine, or 'method'. First separate all
5921 the non-CLASS references by calling resolve_typebound_call
5925 resolve_typebound_subroutine (gfc_code
*code
)
5927 gfc_symbol
*declared
;
5937 st
= code
->expr1
->symtree
;
5939 /* Deal with typebound operators for CLASS objects. */
5940 expr
= code
->expr1
->value
.compcall
.base_object
;
5941 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5942 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5944 /* If the base_object is not a variable, the corresponding actual
5945 argument expression must be stored in e->base_expression so
5946 that the corresponding tree temporary can be used as the base
5947 object in gfc_conv_procedure_call. */
5948 if (expr
->expr_type
!= EXPR_VARIABLE
)
5950 gfc_actual_arglist
*args
;
5952 args
= code
->expr1
->value
.function
.actual
;
5953 for (; args
; args
= args
->next
)
5954 if (expr
== args
->expr
)
5958 /* Since the typebound operators are generic, we have to ensure
5959 that any delays in resolution are corrected and that the vtab
5961 declared
= expr
->ts
.u
.derived
;
5962 c
= gfc_find_component (declared
, "_vptr", true, true);
5963 if (c
->ts
.u
.derived
== NULL
)
5964 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5966 if (!resolve_typebound_call (code
, &name
, NULL
))
5969 /* Use the generic name if it is there. */
5970 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5971 code
->expr1
->symtree
= expr
->symtree
;
5972 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5974 /* Trim away the extraneous references that emerge from nested
5975 use of interface.c (extend_expr). */
5976 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5977 if (class_ref
&& class_ref
->next
)
5979 gfc_free_ref_list (class_ref
->next
);
5980 class_ref
->next
= NULL
;
5982 else if (code
->expr1
->ref
&& !class_ref
)
5984 gfc_free_ref_list (code
->expr1
->ref
);
5985 code
->expr1
->ref
= NULL
;
5988 /* Now use the procedure in the vtable. */
5989 gfc_add_vptr_component (code
->expr1
);
5990 gfc_add_component_ref (code
->expr1
, name
);
5991 code
->expr1
->value
.function
.esym
= NULL
;
5992 if (expr
->expr_type
!= EXPR_VARIABLE
)
5993 code
->expr1
->base_expr
= expr
;
5998 return resolve_typebound_call (code
, NULL
, NULL
);
6000 if (!resolve_ref (code
->expr1
))
6003 /* Get the CLASS declared type. */
6004 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6006 /* Weed out cases of the ultimate component being a derived type. */
6007 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6008 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6010 gfc_free_ref_list (new_ref
);
6011 return resolve_typebound_call (code
, NULL
, NULL
);
6014 if (!resolve_typebound_call (code
, &name
, &overridable
))
6016 gfc_free_ref_list (new_ref
);
6019 ts
= code
->expr1
->ts
;
6023 /* Convert the expression to a procedure pointer component call. */
6024 code
->expr1
->value
.function
.esym
= NULL
;
6025 code
->expr1
->symtree
= st
;
6028 code
->expr1
->ref
= new_ref
;
6030 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6031 gfc_add_vptr_component (code
->expr1
);
6032 gfc_add_component_ref (code
->expr1
, name
);
6034 /* Recover the typespec for the expression. This is really only
6035 necessary for generic procedures, where the additional call
6036 to gfc_add_component_ref seems to throw the collection of the
6037 correct typespec. */
6038 code
->expr1
->ts
= ts
;
6041 gfc_free_ref_list (new_ref
);
6047 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6050 resolve_ppc_call (gfc_code
* c
)
6052 gfc_component
*comp
;
6054 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6055 gcc_assert (comp
!= NULL
);
6057 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6058 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6060 if (!comp
->attr
.subroutine
)
6061 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6063 if (!resolve_ref (c
->expr1
))
6066 if (!update_ppc_arglist (c
->expr1
))
6069 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6071 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6072 !(comp
->ts
.interface
6073 && comp
->ts
.interface
->formal
)))
6076 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6079 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6085 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6088 resolve_expr_ppc (gfc_expr
* e
)
6090 gfc_component
*comp
;
6092 comp
= gfc_get_proc_ptr_comp (e
);
6093 gcc_assert (comp
!= NULL
);
6095 /* Convert to EXPR_FUNCTION. */
6096 e
->expr_type
= EXPR_FUNCTION
;
6097 e
->value
.function
.isym
= NULL
;
6098 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6100 if (comp
->as
!= NULL
)
6101 e
->rank
= comp
->as
->rank
;
6103 if (!comp
->attr
.function
)
6104 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6106 if (!resolve_ref (e
))
6109 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6110 !(comp
->ts
.interface
6111 && comp
->ts
.interface
->formal
)))
6114 if (!update_ppc_arglist (e
))
6117 if (!check_pure_function(e
))
6120 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6127 gfc_is_expandable_expr (gfc_expr
*e
)
6129 gfc_constructor
*con
;
6131 if (e
->expr_type
== EXPR_ARRAY
)
6133 /* Traverse the constructor looking for variables that are flavor
6134 parameter. Parameters must be expanded since they are fully used at
6136 con
= gfc_constructor_first (e
->value
.constructor
);
6137 for (; con
; con
= gfc_constructor_next (con
))
6139 if (con
->expr
->expr_type
== EXPR_VARIABLE
6140 && con
->expr
->symtree
6141 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6142 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6144 if (con
->expr
->expr_type
== EXPR_ARRAY
6145 && gfc_is_expandable_expr (con
->expr
))
6153 /* Resolve an expression. That is, make sure that types of operands agree
6154 with their operators, intrinsic operators are converted to function calls
6155 for overloaded types and unresolved function references are resolved. */
6158 gfc_resolve_expr (gfc_expr
*e
)
6161 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6166 /* inquiry_argument only applies to variables. */
6167 inquiry_save
= inquiry_argument
;
6168 actual_arg_save
= actual_arg
;
6169 first_actual_arg_save
= first_actual_arg
;
6171 if (e
->expr_type
!= EXPR_VARIABLE
)
6173 inquiry_argument
= false;
6175 first_actual_arg
= false;
6178 switch (e
->expr_type
)
6181 t
= resolve_operator (e
);
6187 if (check_host_association (e
))
6188 t
= resolve_function (e
);
6190 t
= resolve_variable (e
);
6192 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6193 && e
->ref
->type
!= REF_SUBSTRING
)
6194 gfc_resolve_substring_charlen (e
);
6199 t
= resolve_typebound_function (e
);
6202 case EXPR_SUBSTRING
:
6203 t
= resolve_ref (e
);
6212 t
= resolve_expr_ppc (e
);
6217 if (!resolve_ref (e
))
6220 t
= gfc_resolve_array_constructor (e
);
6221 /* Also try to expand a constructor. */
6224 expression_rank (e
);
6225 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6226 gfc_expand_constructor (e
, false);
6229 /* This provides the opportunity for the length of constructors with
6230 character valued function elements to propagate the string length
6231 to the expression. */
6232 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6234 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6235 here rather then add a duplicate test for it above. */
6236 gfc_expand_constructor (e
, false);
6237 t
= gfc_resolve_character_array_constructor (e
);
6242 case EXPR_STRUCTURE
:
6243 t
= resolve_ref (e
);
6247 t
= resolve_structure_cons (e
, 0);
6251 t
= gfc_simplify_expr (e
, 0);
6255 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6258 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6261 inquiry_argument
= inquiry_save
;
6262 actual_arg
= actual_arg_save
;
6263 first_actual_arg
= first_actual_arg_save
;
6269 /* Resolve an expression from an iterator. They must be scalar and have
6270 INTEGER or (optionally) REAL type. */
6273 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6274 const char *name_msgid
)
6276 if (!gfc_resolve_expr (expr
))
6279 if (expr
->rank
!= 0)
6281 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6285 if (expr
->ts
.type
!= BT_INTEGER
)
6287 if (expr
->ts
.type
== BT_REAL
)
6290 return gfc_notify_std (GFC_STD_F95_DEL
,
6291 "%s at %L must be integer",
6292 _(name_msgid
), &expr
->where
);
6295 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6302 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6310 /* Resolve the expressions in an iterator structure. If REAL_OK is
6311 false allow only INTEGER type iterators, otherwise allow REAL types.
6312 Set own_scope to true for ac-implied-do and data-implied-do as those
6313 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6316 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6318 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6321 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6322 _("iterator variable")))
6325 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6326 "Start expression in DO loop"))
6329 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6330 "End expression in DO loop"))
6333 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6334 "Step expression in DO loop"))
6337 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6339 if ((iter
->step
->ts
.type
== BT_INTEGER
6340 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6341 || (iter
->step
->ts
.type
== BT_REAL
6342 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6344 gfc_error ("Step expression in DO loop at %L cannot be zero",
6345 &iter
->step
->where
);
6350 /* Convert start, end, and step to the same type as var. */
6351 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6352 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6353 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6355 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6356 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6357 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6359 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6360 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6361 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6363 if (iter
->start
->expr_type
== EXPR_CONSTANT
6364 && iter
->end
->expr_type
== EXPR_CONSTANT
6365 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6368 if (iter
->start
->ts
.type
== BT_INTEGER
)
6370 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6371 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6375 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6376 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6378 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6379 gfc_warning (OPT_Wzerotrip
,
6380 "DO loop at %L will be executed zero times",
6381 &iter
->step
->where
);
6388 /* Traversal function for find_forall_index. f == 2 signals that
6389 that variable itself is not to be checked - only the references. */
6392 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6394 if (expr
->expr_type
!= EXPR_VARIABLE
)
6397 /* A scalar assignment */
6398 if (!expr
->ref
|| *f
== 1)
6400 if (expr
->symtree
->n
.sym
== sym
)
6412 /* Check whether the FORALL index appears in the expression or not.
6413 Returns true if SYM is found in EXPR. */
6416 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6418 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6425 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6426 to be a scalar INTEGER variable. The subscripts and stride are scalar
6427 INTEGERs, and if stride is a constant it must be nonzero.
6428 Furthermore "A subscript or stride in a forall-triplet-spec shall
6429 not contain a reference to any index-name in the
6430 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6433 resolve_forall_iterators (gfc_forall_iterator
*it
)
6435 gfc_forall_iterator
*iter
, *iter2
;
6437 for (iter
= it
; iter
; iter
= iter
->next
)
6439 if (gfc_resolve_expr (iter
->var
)
6440 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6441 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6444 if (gfc_resolve_expr (iter
->start
)
6445 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6446 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6447 &iter
->start
->where
);
6448 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6449 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6451 if (gfc_resolve_expr (iter
->end
)
6452 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6453 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6455 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6456 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6458 if (gfc_resolve_expr (iter
->stride
))
6460 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6461 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6462 &iter
->stride
->where
, "INTEGER");
6464 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6465 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6466 gfc_error ("FORALL stride expression at %L cannot be zero",
6467 &iter
->stride
->where
);
6469 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6470 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6473 for (iter
= it
; iter
; iter
= iter
->next
)
6474 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6476 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6477 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6478 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6479 gfc_error ("FORALL index %qs may not appear in triplet "
6480 "specification at %L", iter
->var
->symtree
->name
,
6481 &iter2
->start
->where
);
6486 /* Given a pointer to a symbol that is a derived type, see if it's
6487 inaccessible, i.e. if it's defined in another module and the components are
6488 PRIVATE. The search is recursive if necessary. Returns zero if no
6489 inaccessible components are found, nonzero otherwise. */
6492 derived_inaccessible (gfc_symbol
*sym
)
6496 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6499 for (c
= sym
->components
; c
; c
= c
->next
)
6501 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6509 /* Resolve the argument of a deallocate expression. The expression must be
6510 a pointer or a full array. */
6513 resolve_deallocate_expr (gfc_expr
*e
)
6515 symbol_attribute attr
;
6516 int allocatable
, pointer
;
6522 if (!gfc_resolve_expr (e
))
6525 if (e
->expr_type
!= EXPR_VARIABLE
)
6528 sym
= e
->symtree
->n
.sym
;
6529 unlimited
= UNLIMITED_POLY(sym
);
6531 if (sym
->ts
.type
== BT_CLASS
)
6533 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6534 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6538 allocatable
= sym
->attr
.allocatable
;
6539 pointer
= sym
->attr
.pointer
;
6541 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6546 if (ref
->u
.ar
.type
!= AR_FULL
6547 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6548 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6553 c
= ref
->u
.c
.component
;
6554 if (c
->ts
.type
== BT_CLASS
)
6556 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6557 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6561 allocatable
= c
->attr
.allocatable
;
6562 pointer
= c
->attr
.pointer
;
6572 attr
= gfc_expr_attr (e
);
6574 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6577 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6583 if (gfc_is_coindexed (e
))
6585 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6590 && !gfc_check_vardef_context (e
, true, true, false,
6591 _("DEALLOCATE object")))
6593 if (!gfc_check_vardef_context (e
, false, true, false,
6594 _("DEALLOCATE object")))
6601 /* Returns true if the expression e contains a reference to the symbol sym. */
6603 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6605 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6612 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6614 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6618 /* Given the expression node e for an allocatable/pointer of derived type to be
6619 allocated, get the expression node to be initialized afterwards (needed for
6620 derived types with default initializers, and derived types with allocatable
6621 components that need nullification.) */
6624 gfc_expr_to_initialize (gfc_expr
*e
)
6630 result
= gfc_copy_expr (e
);
6632 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6633 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6634 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6636 ref
->u
.ar
.type
= AR_FULL
;
6638 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6639 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6644 gfc_free_shape (&result
->shape
, result
->rank
);
6646 /* Recalculate rank, shape, etc. */
6647 gfc_resolve_expr (result
);
6652 /* If the last ref of an expression is an array ref, return a copy of the
6653 expression with that one removed. Otherwise, a copy of the original
6654 expression. This is used for allocate-expressions and pointer assignment
6655 LHS, where there may be an array specification that needs to be stripped
6656 off when using gfc_check_vardef_context. */
6659 remove_last_array_ref (gfc_expr
* e
)
6664 e2
= gfc_copy_expr (e
);
6665 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6666 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6668 gfc_free_ref_list (*r
);
6677 /* Used in resolve_allocate_expr to check that a allocation-object and
6678 a source-expr are conformable. This does not catch all possible
6679 cases; in particular a runtime checking is needed. */
6682 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6685 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6687 /* First compare rank. */
6688 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6689 || (!tail
&& e1
->rank
!= e2
->rank
))
6691 gfc_error ("Source-expr at %L must be scalar or have the "
6692 "same rank as the allocate-object at %L",
6693 &e1
->where
, &e2
->where
);
6704 for (i
= 0; i
< e1
->rank
; i
++)
6706 if (tail
->u
.ar
.start
[i
] == NULL
)
6709 if (tail
->u
.ar
.end
[i
])
6711 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6712 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6713 mpz_add_ui (s
, s
, 1);
6717 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6720 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6722 gfc_error_1 ("Source-expr at %L and allocate-object at %L must "
6723 "have the same shape", &e1
->where
, &e2
->where
);
6736 /* Resolve the expression in an ALLOCATE statement, doing the additional
6737 checks to see whether the expression is OK or not. The expression must
6738 have a trailing array reference that gives the size of the array. */
6741 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6743 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6747 symbol_attribute attr
;
6748 gfc_ref
*ref
, *ref2
;
6751 gfc_symbol
*sym
= NULL
;
6756 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6757 checking of coarrays. */
6758 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6759 if (ref
->next
== NULL
)
6762 if (ref
&& ref
->type
== REF_ARRAY
)
6763 ref
->u
.ar
.in_allocate
= true;
6765 if (!gfc_resolve_expr (e
))
6768 /* Make sure the expression is allocatable or a pointer. If it is
6769 pointer, the next-to-last reference must be a pointer. */
6773 sym
= e
->symtree
->n
.sym
;
6775 /* Check whether ultimate component is abstract and CLASS. */
6778 /* Is the allocate-object unlimited polymorphic? */
6779 unlimited
= UNLIMITED_POLY(e
);
6781 if (e
->expr_type
!= EXPR_VARIABLE
)
6784 attr
= gfc_expr_attr (e
);
6785 pointer
= attr
.pointer
;
6786 dimension
= attr
.dimension
;
6787 codimension
= attr
.codimension
;
6791 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6793 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6794 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6795 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6796 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6797 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6801 allocatable
= sym
->attr
.allocatable
;
6802 pointer
= sym
->attr
.pointer
;
6803 dimension
= sym
->attr
.dimension
;
6804 codimension
= sym
->attr
.codimension
;
6809 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6814 if (ref
->u
.ar
.codimen
> 0)
6817 for (n
= ref
->u
.ar
.dimen
;
6818 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6819 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6826 if (ref
->next
!= NULL
)
6834 gfc_error ("Coindexed allocatable object at %L",
6839 c
= ref
->u
.c
.component
;
6840 if (c
->ts
.type
== BT_CLASS
)
6842 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6843 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6844 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6845 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6846 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6850 allocatable
= c
->attr
.allocatable
;
6851 pointer
= c
->attr
.pointer
;
6852 dimension
= c
->attr
.dimension
;
6853 codimension
= c
->attr
.codimension
;
6854 is_abstract
= c
->attr
.abstract
;
6866 /* Check for F08:C628. */
6867 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6869 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6874 /* Some checks for the SOURCE tag. */
6877 /* Check F03:C631. */
6878 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6880 gfc_error_1 ("Type of entity at %L is type incompatible with "
6881 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6885 /* Check F03:C632 and restriction following Note 6.18. */
6886 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6889 /* Check F03:C633. */
6890 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6892 gfc_error_1 ("The allocate-object at %L and the source-expr at %L "
6893 "shall have the same kind type parameter",
6894 &e
->where
, &code
->expr3
->where
);
6898 /* Check F2008, C642. */
6899 if (code
->expr3
->ts
.type
== BT_DERIVED
6900 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6901 || (code
->expr3
->ts
.u
.derived
->from_intmod
6902 == INTMOD_ISO_FORTRAN_ENV
6903 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6904 == ISOFORTRAN_LOCK_TYPE
)))
6906 gfc_error_1 ("The source-expr at %L shall neither be of type "
6907 "LOCK_TYPE nor have a LOCK_TYPE component if "
6908 "allocate-object at %L is a coarray",
6909 &code
->expr3
->where
, &e
->where
);
6914 /* Check F08:C629. */
6915 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6918 gcc_assert (e
->ts
.type
== BT_CLASS
);
6919 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6920 "type-spec or source-expr", sym
->name
, &e
->where
);
6924 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6926 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6927 code
->ext
.alloc
.ts
.u
.cl
->length
);
6928 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6930 gfc_error ("Allocating %s at %L with type-spec requires the same "
6931 "character-length parameter as in the declaration",
6932 sym
->name
, &e
->where
);
6937 /* In the variable definition context checks, gfc_expr_attr is used
6938 on the expression. This is fooled by the array specification
6939 present in e, thus we have to eliminate that one temporarily. */
6940 e2
= remove_last_array_ref (e
);
6943 t
= gfc_check_vardef_context (e2
, true, true, false,
6944 _("ALLOCATE object"));
6946 t
= gfc_check_vardef_context (e2
, false, true, false,
6947 _("ALLOCATE object"));
6952 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6953 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6955 /* For class arrays, the initialization with SOURCE is done
6956 using _copy and trans_call. It is convenient to exploit that
6957 when the allocated type is different from the declared type but
6958 no SOURCE exists by setting expr3. */
6959 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6961 else if (!code
->expr3
)
6963 /* Set up default initializer if needed. */
6967 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6968 ts
= code
->ext
.alloc
.ts
;
6972 if (ts
.type
== BT_CLASS
)
6973 ts
= ts
.u
.derived
->components
->ts
;
6975 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6977 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6978 init_st
->loc
= code
->loc
;
6979 init_st
->expr1
= gfc_expr_to_initialize (e
);
6980 init_st
->expr2
= init_e
;
6981 init_st
->next
= code
->next
;
6982 code
->next
= init_st
;
6985 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6987 /* Default initialization via MOLD (non-polymorphic). */
6988 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6989 gfc_resolve_expr (rhs
);
6990 gfc_free_expr (code
->expr3
);
6994 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6996 /* Make sure the vtab symbol is present when
6997 the module variables are generated. */
6998 gfc_typespec ts
= e
->ts
;
7000 ts
= code
->expr3
->ts
;
7001 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7002 ts
= code
->ext
.alloc
.ts
;
7004 gfc_find_derived_vtab (ts
.u
.derived
);
7007 e
= gfc_expr_to_initialize (e
);
7009 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7011 /* Again, make sure the vtab symbol is present when
7012 the module variables are generated. */
7013 gfc_typespec
*ts
= NULL
;
7015 ts
= &code
->expr3
->ts
;
7017 ts
= &code
->ext
.alloc
.ts
;
7024 e
= gfc_expr_to_initialize (e
);
7027 if (dimension
== 0 && codimension
== 0)
7030 /* Make sure the last reference node is an array specification. */
7032 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7033 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7035 gfc_error ("Array specification required in ALLOCATE statement "
7036 "at %L", &e
->where
);
7040 /* Make sure that the array section reference makes sense in the
7041 context of an ALLOCATE specification. */
7046 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7047 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7049 gfc_error ("Coarray specification required in ALLOCATE statement "
7050 "at %L", &e
->where
);
7054 for (i
= 0; i
< ar
->dimen
; i
++)
7056 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7059 switch (ar
->dimen_type
[i
])
7065 if (ar
->start
[i
] != NULL
7066 && ar
->end
[i
] != NULL
7067 && ar
->stride
[i
] == NULL
)
7070 /* Fall Through... */
7075 case DIMEN_THIS_IMAGE
:
7076 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7082 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7084 sym
= a
->expr
->symtree
->n
.sym
;
7086 /* TODO - check derived type components. */
7087 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7090 if ((ar
->start
[i
] != NULL
7091 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7092 || (ar
->end
[i
] != NULL
7093 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7095 gfc_error ("%qs must not appear in the array specification at "
7096 "%L in the same ALLOCATE statement where it is "
7097 "itself allocated", sym
->name
, &ar
->where
);
7103 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7105 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7106 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7108 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7110 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7111 "statement at %L", &e
->where
);
7117 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7118 && ar
->stride
[i
] == NULL
)
7121 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7134 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7136 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7137 gfc_alloc
*a
, *p
, *q
;
7140 errmsg
= code
->expr2
;
7142 /* Check the stat variable. */
7145 gfc_check_vardef_context (stat
, false, false, false,
7146 _("STAT variable"));
7148 if ((stat
->ts
.type
!= BT_INTEGER
7149 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7150 || stat
->ref
->type
== REF_COMPONENT
)))
7152 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7153 "variable", &stat
->where
);
7155 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7156 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7158 gfc_ref
*ref1
, *ref2
;
7161 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7162 ref1
= ref1
->next
, ref2
= ref2
->next
)
7164 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7166 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7175 gfc_error ("Stat-variable at %L shall not be %sd within "
7176 "the same %s statement", &stat
->where
, fcn
, fcn
);
7182 /* Check the errmsg variable. */
7186 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7189 gfc_check_vardef_context (errmsg
, false, false, false,
7190 _("ERRMSG variable"));
7192 if ((errmsg
->ts
.type
!= BT_CHARACTER
7194 && (errmsg
->ref
->type
== REF_ARRAY
7195 || errmsg
->ref
->type
== REF_COMPONENT
)))
7196 || errmsg
->rank
> 0 )
7197 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7198 "variable", &errmsg
->where
);
7200 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7201 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7203 gfc_ref
*ref1
, *ref2
;
7206 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7207 ref1
= ref1
->next
, ref2
= ref2
->next
)
7209 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7211 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7220 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7221 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7227 /* Check that an allocate-object appears only once in the statement. */
7229 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7232 for (q
= p
->next
; q
; q
= q
->next
)
7235 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7237 /* This is a potential collision. */
7238 gfc_ref
*pr
= pe
->ref
;
7239 gfc_ref
*qr
= qe
->ref
;
7241 /* Follow the references until
7242 a) They start to differ, in which case there is no error;
7243 you can deallocate a%b and a%c in a single statement
7244 b) Both of them stop, which is an error
7245 c) One of them stops, which is also an error. */
7248 if (pr
== NULL
&& qr
== NULL
)
7250 gfc_error_1 ("Allocate-object at %L also appears at %L",
7251 &pe
->where
, &qe
->where
);
7254 else if (pr
!= NULL
&& qr
== NULL
)
7256 gfc_error_1 ("Allocate-object at %L is subobject of"
7257 " object at %L", &pe
->where
, &qe
->where
);
7260 else if (pr
== NULL
&& qr
!= NULL
)
7262 gfc_error_1 ("Allocate-object at %L is subobject of"
7263 " object at %L", &qe
->where
, &pe
->where
);
7266 /* Here, pr != NULL && qr != NULL */
7267 gcc_assert(pr
->type
== qr
->type
);
7268 if (pr
->type
== REF_ARRAY
)
7270 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7272 gcc_assert (qr
->type
== REF_ARRAY
);
7274 if (pr
->next
&& qr
->next
)
7277 gfc_array_ref
*par
= &(pr
->u
.ar
);
7278 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7280 for (i
=0; i
<par
->dimen
; i
++)
7282 if ((par
->start
[i
] != NULL
7283 || qar
->start
[i
] != NULL
)
7284 && gfc_dep_compare_expr (par
->start
[i
],
7285 qar
->start
[i
]) != 0)
7292 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7305 if (strcmp (fcn
, "ALLOCATE") == 0)
7307 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7308 resolve_allocate_expr (a
->expr
, code
);
7312 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7313 resolve_deallocate_expr (a
->expr
);
7318 /************ SELECT CASE resolution subroutines ************/
7320 /* Callback function for our mergesort variant. Determines interval
7321 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7322 op1 > op2. Assumes we're not dealing with the default case.
7323 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7324 There are nine situations to check. */
7327 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7331 if (op1
->low
== NULL
) /* op1 = (:L) */
7333 /* op2 = (:N), so overlap. */
7335 /* op2 = (M:) or (M:N), L < M */
7336 if (op2
->low
!= NULL
7337 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7340 else if (op1
->high
== NULL
) /* op1 = (K:) */
7342 /* op2 = (M:), so overlap. */
7344 /* op2 = (:N) or (M:N), K > N */
7345 if (op2
->high
!= NULL
7346 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7349 else /* op1 = (K:L) */
7351 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7352 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7354 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7355 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7357 else /* op2 = (M:N) */
7361 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7364 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7373 /* Merge-sort a double linked case list, detecting overlap in the
7374 process. LIST is the head of the double linked case list before it
7375 is sorted. Returns the head of the sorted list if we don't see any
7376 overlap, or NULL otherwise. */
7379 check_case_overlap (gfc_case
*list
)
7381 gfc_case
*p
, *q
, *e
, *tail
;
7382 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7384 /* If the passed list was empty, return immediately. */
7391 /* Loop unconditionally. The only exit from this loop is a return
7392 statement, when we've finished sorting the case list. */
7399 /* Count the number of merges we do in this pass. */
7402 /* Loop while there exists a merge to be done. */
7407 /* Count this merge. */
7410 /* Cut the list in two pieces by stepping INSIZE places
7411 forward in the list, starting from P. */
7414 for (i
= 0; i
< insize
; i
++)
7423 /* Now we have two lists. Merge them! */
7424 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7426 /* See from which the next case to merge comes from. */
7429 /* P is empty so the next case must come from Q. */
7434 else if (qsize
== 0 || q
== NULL
)
7443 cmp
= compare_cases (p
, q
);
7446 /* The whole case range for P is less than the
7454 /* The whole case range for Q is greater than
7455 the case range for P. */
7462 /* The cases overlap, or they are the same
7463 element in the list. Either way, we must
7464 issue an error and get the next case from P. */
7465 /* FIXME: Sort P and Q by line number. */
7466 gfc_error_1 ("CASE label at %L overlaps with CASE "
7467 "label at %L", &p
->where
, &q
->where
);
7475 /* Add the next element to the merged list. */
7484 /* P has now stepped INSIZE places along, and so has Q. So
7485 they're the same. */
7490 /* If we have done only one merge or none at all, we've
7491 finished sorting the cases. */
7500 /* Otherwise repeat, merging lists twice the size. */
7506 /* Check to see if an expression is suitable for use in a CASE statement.
7507 Makes sure that all case expressions are scalar constants of the same
7508 type. Return false if anything is wrong. */
7511 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7513 if (e
== NULL
) return true;
7515 if (e
->ts
.type
!= case_expr
->ts
.type
)
7517 gfc_error ("Expression in CASE statement at %L must be of type %s",
7518 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7522 /* C805 (R808) For a given case-construct, each case-value shall be of
7523 the same type as case-expr. For character type, length differences
7524 are allowed, but the kind type parameters shall be the same. */
7526 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7528 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7529 &e
->where
, case_expr
->ts
.kind
);
7533 /* Convert the case value kind to that of case expression kind,
7536 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7537 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7541 gfc_error ("Expression in CASE statement at %L must be scalar",
7550 /* Given a completely parsed select statement, we:
7552 - Validate all expressions and code within the SELECT.
7553 - Make sure that the selection expression is not of the wrong type.
7554 - Make sure that no case ranges overlap.
7555 - Eliminate unreachable cases and unreachable code resulting from
7556 removing case labels.
7558 The standard does allow unreachable cases, e.g. CASE (5:3). But
7559 they are a hassle for code generation, and to prevent that, we just
7560 cut them out here. This is not necessary for overlapping cases
7561 because they are illegal and we never even try to generate code.
7563 We have the additional caveat that a SELECT construct could have
7564 been a computed GOTO in the source code. Fortunately we can fairly
7565 easily work around that here: The case_expr for a "real" SELECT CASE
7566 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7567 we have to do is make sure that the case_expr is a scalar integer
7571 resolve_select (gfc_code
*code
, bool select_type
)
7574 gfc_expr
*case_expr
;
7575 gfc_case
*cp
, *default_case
, *tail
, *head
;
7576 int seen_unreachable
;
7582 if (code
->expr1
== NULL
)
7584 /* This was actually a computed GOTO statement. */
7585 case_expr
= code
->expr2
;
7586 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7587 gfc_error ("Selection expression in computed GOTO statement "
7588 "at %L must be a scalar integer expression",
7591 /* Further checking is not necessary because this SELECT was built
7592 by the compiler, so it should always be OK. Just move the
7593 case_expr from expr2 to expr so that we can handle computed
7594 GOTOs as normal SELECTs from here on. */
7595 code
->expr1
= code
->expr2
;
7600 case_expr
= code
->expr1
;
7601 type
= case_expr
->ts
.type
;
7604 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7606 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7607 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7609 /* Punt. Going on here just produce more garbage error messages. */
7614 if (!select_type
&& case_expr
->rank
!= 0)
7616 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7617 "expression", &case_expr
->where
);
7623 /* Raise a warning if an INTEGER case value exceeds the range of
7624 the case-expr. Later, all expressions will be promoted to the
7625 largest kind of all case-labels. */
7627 if (type
== BT_INTEGER
)
7628 for (body
= code
->block
; body
; body
= body
->block
)
7629 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7632 && gfc_check_integer_range (cp
->low
->value
.integer
,
7633 case_expr
->ts
.kind
) != ARITH_OK
)
7634 gfc_warning ("Expression in CASE statement at %L is "
7635 "not in the range of %s", &cp
->low
->where
,
7636 gfc_typename (&case_expr
->ts
));
7639 && cp
->low
!= cp
->high
7640 && gfc_check_integer_range (cp
->high
->value
.integer
,
7641 case_expr
->ts
.kind
) != ARITH_OK
)
7642 gfc_warning ("Expression in CASE statement at %L is "
7643 "not in the range of %s", &cp
->high
->where
,
7644 gfc_typename (&case_expr
->ts
));
7647 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7648 of the SELECT CASE expression and its CASE values. Walk the lists
7649 of case values, and if we find a mismatch, promote case_expr to
7650 the appropriate kind. */
7652 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7654 for (body
= code
->block
; body
; body
= body
->block
)
7656 /* Walk the case label list. */
7657 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7659 /* Intercept the DEFAULT case. It does not have a kind. */
7660 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7663 /* Unreachable case ranges are discarded, so ignore. */
7664 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7665 && cp
->low
!= cp
->high
7666 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7670 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7671 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7673 if (cp
->high
!= NULL
7674 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7675 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7680 /* Assume there is no DEFAULT case. */
7681 default_case
= NULL
;
7686 for (body
= code
->block
; body
; body
= body
->block
)
7688 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7690 seen_unreachable
= 0;
7692 /* Walk the case label list, making sure that all case labels
7694 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7696 /* Count the number of cases in the whole construct. */
7699 /* Intercept the DEFAULT case. */
7700 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7702 if (default_case
!= NULL
)
7704 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
7705 "by a second DEFAULT CASE at %L",
7706 &default_case
->where
, &cp
->where
);
7717 /* Deal with single value cases and case ranges. Errors are
7718 issued from the validation function. */
7719 if (!validate_case_label_expr (cp
->low
, case_expr
)
7720 || !validate_case_label_expr (cp
->high
, case_expr
))
7726 if (type
== BT_LOGICAL
7727 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7728 || cp
->low
!= cp
->high
))
7730 gfc_error ("Logical range in CASE statement at %L is not "
7731 "allowed", &cp
->low
->where
);
7736 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7739 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7740 if (value
& seen_logical
)
7742 gfc_error ("Constant logical value in CASE statement "
7743 "is repeated at %L",
7748 seen_logical
|= value
;
7751 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7752 && cp
->low
!= cp
->high
7753 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7755 if (warn_surprising
)
7756 gfc_warning (OPT_Wsurprising
,
7757 "Range specification at %L can never be matched",
7760 cp
->unreachable
= 1;
7761 seen_unreachable
= 1;
7765 /* If the case range can be matched, it can also overlap with
7766 other cases. To make sure it does not, we put it in a
7767 double linked list here. We sort that with a merge sort
7768 later on to detect any overlapping cases. */
7772 head
->right
= head
->left
= NULL
;
7777 tail
->right
->left
= tail
;
7784 /* It there was a failure in the previous case label, give up
7785 for this case label list. Continue with the next block. */
7789 /* See if any case labels that are unreachable have been seen.
7790 If so, we eliminate them. This is a bit of a kludge because
7791 the case lists for a single case statement (label) is a
7792 single forward linked lists. */
7793 if (seen_unreachable
)
7795 /* Advance until the first case in the list is reachable. */
7796 while (body
->ext
.block
.case_list
!= NULL
7797 && body
->ext
.block
.case_list
->unreachable
)
7799 gfc_case
*n
= body
->ext
.block
.case_list
;
7800 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7802 gfc_free_case_list (n
);
7805 /* Strip all other unreachable cases. */
7806 if (body
->ext
.block
.case_list
)
7808 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
7810 if (cp
->next
->unreachable
)
7812 gfc_case
*n
= cp
->next
;
7813 cp
->next
= cp
->next
->next
;
7815 gfc_free_case_list (n
);
7822 /* See if there were overlapping cases. If the check returns NULL,
7823 there was overlap. In that case we don't do anything. If head
7824 is non-NULL, we prepend the DEFAULT case. The sorted list can
7825 then used during code generation for SELECT CASE constructs with
7826 a case expression of a CHARACTER type. */
7829 head
= check_case_overlap (head
);
7831 /* Prepend the default_case if it is there. */
7832 if (head
!= NULL
&& default_case
)
7834 default_case
->left
= NULL
;
7835 default_case
->right
= head
;
7836 head
->left
= default_case
;
7840 /* Eliminate dead blocks that may be the result if we've seen
7841 unreachable case labels for a block. */
7842 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7844 if (body
->block
->ext
.block
.case_list
== NULL
)
7846 /* Cut the unreachable block from the code chain. */
7847 gfc_code
*c
= body
->block
;
7848 body
->block
= c
->block
;
7850 /* Kill the dead block, but not the blocks below it. */
7852 gfc_free_statements (c
);
7856 /* More than two cases is legal but insane for logical selects.
7857 Issue a warning for it. */
7858 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
7859 gfc_warning (OPT_Wsurprising
,
7860 "Logical SELECT CASE block at %L has more that two cases",
7865 /* Check if a derived type is extensible. */
7868 gfc_type_is_extensible (gfc_symbol
*sym
)
7870 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7871 || (sym
->attr
.is_class
7872 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7876 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7877 correct as well as possibly the array-spec. */
7880 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7884 gcc_assert (sym
->assoc
);
7885 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7887 /* If this is for SELECT TYPE, the target may not yet be set. In that
7888 case, return. Resolution will be called later manually again when
7890 target
= sym
->assoc
->target
;
7893 gcc_assert (!sym
->assoc
->dangling
);
7895 if (resolve_target
&& !gfc_resolve_expr (target
))
7898 /* For variable targets, we get some attributes from the target. */
7899 if (target
->expr_type
== EXPR_VARIABLE
)
7903 gcc_assert (target
->symtree
);
7904 tsym
= target
->symtree
->n
.sym
;
7906 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7907 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7909 sym
->attr
.target
= tsym
->attr
.target
7910 || gfc_expr_attr (target
).pointer
;
7911 if (is_subref_array (target
))
7912 sym
->attr
.subref_array_pointer
= 1;
7915 /* Get type if this was not already set. Note that it can be
7916 some other type than the target in case this is a SELECT TYPE
7917 selector! So we must not update when the type is already there. */
7918 if (sym
->ts
.type
== BT_UNKNOWN
)
7919 sym
->ts
= target
->ts
;
7920 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7922 /* See if this is a valid association-to-variable. */
7923 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7924 && !gfc_has_vector_subscript (target
));
7926 /* Finally resolve if this is an array or not. */
7927 if (sym
->attr
.dimension
&& target
->rank
== 0)
7929 gfc_error ("Associate-name %qs at %L is used as array",
7930 sym
->name
, &sym
->declared_at
);
7931 sym
->attr
.dimension
= 0;
7935 /* We cannot deal with class selectors that need temporaries. */
7936 if (target
->ts
.type
== BT_CLASS
7937 && gfc_ref_needs_temporary_p (target
->ref
))
7939 gfc_error ("CLASS selector at %L needs a temporary which is not "
7940 "yet implemented", &target
->where
);
7944 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7945 sym
->attr
.dimension
= 1;
7946 else if (target
->ts
.type
== BT_CLASS
)
7947 gfc_fix_class_refs (target
);
7949 /* The associate-name will have a correct type by now. Make absolutely
7950 sure that it has not picked up a dimension attribute. */
7951 if (sym
->ts
.type
== BT_CLASS
)
7952 sym
->attr
.dimension
= 0;
7954 if (sym
->attr
.dimension
)
7956 sym
->as
= gfc_get_array_spec ();
7957 sym
->as
->rank
= target
->rank
;
7958 sym
->as
->type
= AS_DEFERRED
;
7959 sym
->as
->corank
= gfc_get_corank (target
);
7962 /* Mark this as an associate variable. */
7963 sym
->attr
.associate_var
= 1;
7965 /* If the target is a good class object, so is the associate variable. */
7966 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7967 sym
->attr
.class_ok
= 1;
7971 /* Resolve a SELECT TYPE statement. */
7974 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7976 gfc_symbol
*selector_type
;
7977 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7978 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7981 char name
[GFC_MAX_SYMBOL_LEN
];
7986 ns
= code
->ext
.block
.ns
;
7989 /* Check for F03:C813. */
7990 if (code
->expr1
->ts
.type
!= BT_CLASS
7991 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7993 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7994 "at %L", &code
->loc
);
7998 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8003 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8004 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8005 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8007 /* F2008: C803 The selector expression must not be coindexed. */
8008 if (gfc_is_coindexed (code
->expr2
))
8010 gfc_error ("Selector at %L must not be coindexed",
8011 &code
->expr2
->where
);
8018 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8020 if (gfc_is_coindexed (code
->expr1
))
8022 gfc_error ("Selector at %L must not be coindexed",
8023 &code
->expr1
->where
);
8028 /* Loop over TYPE IS / CLASS IS cases. */
8029 for (body
= code
->block
; body
; body
= body
->block
)
8031 c
= body
->ext
.block
.case_list
;
8033 /* Check F03:C815. */
8034 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8035 && !selector_type
->attr
.unlimited_polymorphic
8036 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8038 gfc_error ("Derived type %qs at %L must be extensible",
8039 c
->ts
.u
.derived
->name
, &c
->where
);
8044 /* Check F03:C816. */
8045 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8046 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8047 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8049 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8050 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8051 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8053 gfc_error ("Unexpected intrinsic type %qs at %L",
8054 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8059 /* Check F03:C814. */
8060 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8062 gfc_error ("The type-spec at %L shall specify that each length "
8063 "type parameter is assumed", &c
->where
);
8068 /* Intercept the DEFAULT case. */
8069 if (c
->ts
.type
== BT_UNKNOWN
)
8071 /* Check F03:C818. */
8074 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
8075 "by a second DEFAULT CASE at %L",
8076 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8081 default_case
= body
;
8088 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8089 target if present. If there are any EXIT statements referring to the
8090 SELECT TYPE construct, this is no problem because the gfc_code
8091 reference stays the same and EXIT is equally possible from the BLOCK
8092 it is changed to. */
8093 code
->op
= EXEC_BLOCK
;
8096 gfc_association_list
* assoc
;
8098 assoc
= gfc_get_association_list ();
8099 assoc
->st
= code
->expr1
->symtree
;
8100 assoc
->target
= gfc_copy_expr (code
->expr2
);
8101 assoc
->target
->where
= code
->expr2
->where
;
8102 /* assoc->variable will be set by resolve_assoc_var. */
8104 code
->ext
.block
.assoc
= assoc
;
8105 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8107 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8110 code
->ext
.block
.assoc
= NULL
;
8112 /* Add EXEC_SELECT to switch on type. */
8113 new_st
= gfc_get_code (code
->op
);
8114 new_st
->expr1
= code
->expr1
;
8115 new_st
->expr2
= code
->expr2
;
8116 new_st
->block
= code
->block
;
8117 code
->expr1
= code
->expr2
= NULL
;
8122 ns
->code
->next
= new_st
;
8124 code
->op
= EXEC_SELECT
;
8126 gfc_add_vptr_component (code
->expr1
);
8127 gfc_add_hash_component (code
->expr1
);
8129 /* Loop over TYPE IS / CLASS IS cases. */
8130 for (body
= code
->block
; body
; body
= body
->block
)
8132 c
= body
->ext
.block
.case_list
;
8134 if (c
->ts
.type
== BT_DERIVED
)
8135 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8136 c
->ts
.u
.derived
->hash_value
);
8137 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8142 ivtab
= gfc_find_vtab (&c
->ts
);
8143 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8144 e
= CLASS_DATA (ivtab
)->initializer
;
8145 c
->low
= c
->high
= gfc_copy_expr (e
);
8148 else if (c
->ts
.type
== BT_UNKNOWN
)
8151 /* Associate temporary to selector. This should only be done
8152 when this case is actually true, so build a new ASSOCIATE
8153 that does precisely this here (instead of using the
8156 if (c
->ts
.type
== BT_CLASS
)
8157 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8158 else if (c
->ts
.type
== BT_DERIVED
)
8159 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8160 else if (c
->ts
.type
== BT_CHARACTER
)
8162 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8163 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8164 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8165 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8166 charlen
, c
->ts
.kind
);
8169 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8172 st
= gfc_find_symtree (ns
->sym_root
, name
);
8173 gcc_assert (st
->n
.sym
->assoc
);
8174 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8175 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8176 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8177 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8179 new_st
= gfc_get_code (EXEC_BLOCK
);
8180 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8181 new_st
->ext
.block
.ns
->code
= body
->next
;
8182 body
->next
= new_st
;
8184 /* Chain in the new list only if it is marked as dangling. Otherwise
8185 there is a CASE label overlap and this is already used. Just ignore,
8186 the error is diagnosed elsewhere. */
8187 if (st
->n
.sym
->assoc
->dangling
)
8189 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8190 st
->n
.sym
->assoc
->dangling
= 0;
8193 resolve_assoc_var (st
->n
.sym
, false);
8196 /* Take out CLASS IS cases for separate treatment. */
8198 while (body
&& body
->block
)
8200 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8202 /* Add to class_is list. */
8203 if (class_is
== NULL
)
8205 class_is
= body
->block
;
8210 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8211 tail
->block
= body
->block
;
8214 /* Remove from EXEC_SELECT list. */
8215 body
->block
= body
->block
->block
;
8228 /* Add a default case to hold the CLASS IS cases. */
8229 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8230 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8232 tail
->ext
.block
.case_list
= gfc_get_case ();
8233 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8235 default_case
= tail
;
8238 /* More than one CLASS IS block? */
8239 if (class_is
->block
)
8243 /* Sort CLASS IS blocks by extension level. */
8247 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8250 /* F03:C817 (check for doubles). */
8251 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8252 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8254 gfc_error ("Double CLASS IS block in SELECT TYPE "
8256 &c2
->ext
.block
.case_list
->where
);
8259 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8260 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8263 (*c1
)->block
= c2
->block
;
8273 /* Generate IF chain. */
8274 if_st
= gfc_get_code (EXEC_IF
);
8276 for (body
= class_is
; body
; body
= body
->block
)
8278 new_st
->block
= gfc_get_code (EXEC_IF
);
8279 new_st
= new_st
->block
;
8280 /* Set up IF condition: Call _gfortran_is_extension_of. */
8281 new_st
->expr1
= gfc_get_expr ();
8282 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8283 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8284 new_st
->expr1
->ts
.kind
= 4;
8285 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8286 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8287 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8288 /* Set up arguments. */
8289 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8290 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8291 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8292 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8293 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8294 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8295 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8296 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8297 new_st
->next
= body
->next
;
8299 if (default_case
->next
)
8301 new_st
->block
= gfc_get_code (EXEC_IF
);
8302 new_st
= new_st
->block
;
8303 new_st
->next
= default_case
->next
;
8306 /* Replace CLASS DEFAULT code by the IF chain. */
8307 default_case
->next
= if_st
;
8310 /* Resolve the internal code. This can not be done earlier because
8311 it requires that the sym->assoc of selectors is set already. */
8312 gfc_current_ns
= ns
;
8313 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8314 gfc_current_ns
= old_ns
;
8316 resolve_select (code
, true);
8320 /* Resolve a transfer statement. This is making sure that:
8321 -- a derived type being transferred has only non-pointer components
8322 -- a derived type being transferred doesn't have private components, unless
8323 it's being transferred from the module where the type was defined
8324 -- we're not trying to transfer a whole assumed size array. */
8327 resolve_transfer (gfc_code
*code
)
8336 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8337 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8338 exp
= exp
->value
.op
.op1
;
8340 if (exp
&& exp
->expr_type
== EXPR_NULL
8343 gfc_error ("Invalid context for NULL () intrinsic at %L",
8348 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8349 && exp
->expr_type
!= EXPR_FUNCTION
))
8352 /* If we are reading, the variable will be changed. Note that
8353 code->ext.dt may be NULL if the TRANSFER is related to
8354 an INQUIRE statement -- but in this case, we are not reading, either. */
8355 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8356 && !gfc_check_vardef_context (exp
, false, false, false,
8360 sym
= exp
->symtree
->n
.sym
;
8363 /* Go to actual component transferred. */
8364 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8365 if (ref
->type
== REF_COMPONENT
)
8366 ts
= &ref
->u
.c
.component
->ts
;
8368 if (ts
->type
== BT_CLASS
)
8370 /* FIXME: Test for defined input/output. */
8371 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8372 "it is processed by a defined input/output procedure",
8377 if (ts
->type
== BT_DERIVED
)
8379 /* Check that transferred derived type doesn't contain POINTER
8381 if (ts
->u
.derived
->attr
.pointer_comp
)
8383 gfc_error ("Data transfer element at %L cannot have POINTER "
8384 "components unless it is processed by a defined "
8385 "input/output procedure", &code
->loc
);
8390 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8392 gfc_error ("Data transfer element at %L cannot have "
8393 "procedure pointer components", &code
->loc
);
8397 if (ts
->u
.derived
->attr
.alloc_comp
)
8399 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8400 "components unless it is processed by a defined "
8401 "input/output procedure", &code
->loc
);
8405 /* C_PTR and C_FUNPTR have private components which means they can not
8406 be printed. However, if -std=gnu and not -pedantic, allow
8407 the component to be printed to help debugging. */
8408 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8410 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8411 "cannot have PRIVATE components", &code
->loc
))
8414 else if (derived_inaccessible (ts
->u
.derived
))
8416 gfc_error ("Data transfer element at %L cannot have "
8417 "PRIVATE components",&code
->loc
);
8422 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8423 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8425 gfc_error ("Data transfer element at %L cannot be a full reference to "
8426 "an assumed-size array", &code
->loc
);
8432 /*********** Toplevel code resolution subroutines ***********/
8434 /* Find the set of labels that are reachable from this block. We also
8435 record the last statement in each block. */
8438 find_reachable_labels (gfc_code
*block
)
8445 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8447 /* Collect labels in this block. We don't keep those corresponding
8448 to END {IF|SELECT}, these are checked in resolve_branch by going
8449 up through the code_stack. */
8450 for (c
= block
; c
; c
= c
->next
)
8452 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8453 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8456 /* Merge with labels from parent block. */
8459 gcc_assert (cs_base
->prev
->reachable_labels
);
8460 bitmap_ior_into (cs_base
->reachable_labels
,
8461 cs_base
->prev
->reachable_labels
);
8467 resolve_lock_unlock (gfc_code
*code
)
8469 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8470 && code
->expr1
->value
.function
.isym
8471 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8472 remove_caf_get_intrinsic (code
->expr1
);
8474 if (code
->expr1
->ts
.type
!= BT_DERIVED
8475 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8476 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8477 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8478 || code
->expr1
->rank
!= 0
8479 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8480 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8481 &code
->expr1
->where
);
8485 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8486 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8487 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8488 &code
->expr2
->where
);
8491 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8492 _("STAT variable")))
8497 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8498 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8499 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8500 &code
->expr3
->where
);
8503 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8504 _("ERRMSG variable")))
8507 /* Check ACQUIRED_LOCK. */
8509 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8510 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8511 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8512 "variable", &code
->expr4
->where
);
8515 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8516 _("ACQUIRED_LOCK variable")))
8522 resolve_critical (gfc_code
*code
)
8524 gfc_symtree
*symtree
;
8525 gfc_symbol
*lock_type
;
8526 char name
[GFC_MAX_SYMBOL_LEN
];
8527 static int serial
= 0;
8529 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8532 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8533 GFC_PREFIX ("lock_type"));
8535 lock_type
= symtree
->n
.sym
;
8538 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8541 lock_type
= symtree
->n
.sym
;
8542 lock_type
->attr
.flavor
= FL_DERIVED
;
8543 lock_type
->attr
.zero_comp
= 1;
8544 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8545 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8548 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8549 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8552 code
->resolved_sym
= symtree
->n
.sym
;
8553 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8554 symtree
->n
.sym
->attr
.referenced
= 1;
8555 symtree
->n
.sym
->attr
.artificial
= 1;
8556 symtree
->n
.sym
->attr
.codimension
= 1;
8557 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8558 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8559 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8560 symtree
->n
.sym
->as
->corank
= 1;
8561 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8562 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8563 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8569 resolve_sync (gfc_code
*code
)
8571 /* Check imageset. The * case matches expr1 == NULL. */
8574 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8575 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8576 "INTEGER expression", &code
->expr1
->where
);
8577 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8578 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8579 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8580 &code
->expr1
->where
);
8581 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8582 && gfc_simplify_expr (code
->expr1
, 0))
8584 gfc_constructor
*cons
;
8585 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8586 for (; cons
; cons
= gfc_constructor_next (cons
))
8587 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8588 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8589 gfc_error ("Imageset argument at %L must between 1 and "
8590 "num_images()", &cons
->expr
->where
);
8596 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8597 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8598 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8599 &code
->expr2
->where
);
8603 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8604 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8605 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8606 &code
->expr3
->where
);
8610 /* Given a branch to a label, see if the branch is conforming.
8611 The code node describes where the branch is located. */
8614 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8621 /* Step one: is this a valid branching target? */
8623 if (label
->defined
== ST_LABEL_UNKNOWN
)
8625 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8630 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8632 gfc_error_1 ("Statement at %L is not a valid branch target statement "
8633 "for the branch statement at %L", &label
->where
, &code
->loc
);
8637 /* Step two: make sure this branch is not a branch to itself ;-) */
8639 if (code
->here
== label
)
8641 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8645 /* Step three: See if the label is in the same block as the
8646 branching statement. The hard work has been done by setting up
8647 the bitmap reachable_labels. */
8649 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8651 /* Check now whether there is a CRITICAL construct; if so, check
8652 whether the label is still visible outside of the CRITICAL block,
8653 which is invalid. */
8654 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8656 if (stack
->current
->op
== EXEC_CRITICAL
8657 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8658 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for "
8659 "label at %L", &code
->loc
, &label
->where
);
8660 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8661 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8662 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct "
8663 "for label at %L", &code
->loc
, &label
->where
);
8669 /* Step four: If we haven't found the label in the bitmap, it may
8670 still be the label of the END of the enclosing block, in which
8671 case we find it by going up the code_stack. */
8673 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8675 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8677 if (stack
->current
->op
== EXEC_CRITICAL
)
8679 /* Note: A label at END CRITICAL does not leave the CRITICAL
8680 construct as END CRITICAL is still part of it. */
8681 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label"
8682 " at %L", &code
->loc
, &label
->where
);
8685 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8687 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for "
8688 "label at %L", &code
->loc
, &label
->where
);
8695 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8699 /* The label is not in an enclosing block, so illegal. This was
8700 allowed in Fortran 66, so we allow it as extension. No
8701 further checks are necessary in this case. */
8702 gfc_notify_std_1 (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8703 "as the GOTO statement at %L", &label
->where
,
8709 /* Check whether EXPR1 has the same shape as EXPR2. */
8712 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8714 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8715 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8716 bool result
= false;
8719 /* Compare the rank. */
8720 if (expr1
->rank
!= expr2
->rank
)
8723 /* Compare the size of each dimension. */
8724 for (i
=0; i
<expr1
->rank
; i
++)
8726 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8729 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8732 if (mpz_cmp (shape
[i
], shape2
[i
]))
8736 /* When either of the two expression is an assumed size array, we
8737 ignore the comparison of dimension sizes. */
8742 gfc_clear_shape (shape
, i
);
8743 gfc_clear_shape (shape2
, i
);
8748 /* Check whether a WHERE assignment target or a WHERE mask expression
8749 has the same shape as the outmost WHERE mask expression. */
8752 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8758 cblock
= code
->block
;
8760 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8761 In case of nested WHERE, only the outmost one is stored. */
8762 if (mask
== NULL
) /* outmost WHERE */
8764 else /* inner WHERE */
8771 /* Check if the mask-expr has a consistent shape with the
8772 outmost WHERE mask-expr. */
8773 if (!resolve_where_shape (cblock
->expr1
, e
))
8774 gfc_error ("WHERE mask at %L has inconsistent shape",
8775 &cblock
->expr1
->where
);
8778 /* the assignment statement of a WHERE statement, or the first
8779 statement in where-body-construct of a WHERE construct */
8780 cnext
= cblock
->next
;
8785 /* WHERE assignment statement */
8788 /* Check shape consistent for WHERE assignment target. */
8789 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8790 gfc_error ("WHERE assignment target at %L has "
8791 "inconsistent shape", &cnext
->expr1
->where
);
8795 case EXEC_ASSIGN_CALL
:
8796 resolve_call (cnext
);
8797 if (!cnext
->resolved_sym
->attr
.elemental
)
8798 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8799 &cnext
->ext
.actual
->expr
->where
);
8802 /* WHERE or WHERE construct is part of a where-body-construct */
8804 resolve_where (cnext
, e
);
8808 gfc_error ("Unsupported statement inside WHERE at %L",
8811 /* the next statement within the same where-body-construct */
8812 cnext
= cnext
->next
;
8814 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8815 cblock
= cblock
->block
;
8820 /* Resolve assignment in FORALL construct.
8821 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8822 FORALL index variables. */
8825 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8829 for (n
= 0; n
< nvar
; n
++)
8831 gfc_symbol
*forall_index
;
8833 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8835 /* Check whether the assignment target is one of the FORALL index
8837 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8838 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8839 gfc_error ("Assignment to a FORALL index variable at %L",
8840 &code
->expr1
->where
);
8843 /* If one of the FORALL index variables doesn't appear in the
8844 assignment variable, then there could be a many-to-one
8845 assignment. Emit a warning rather than an error because the
8846 mask could be resolving this problem. */
8847 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8848 gfc_warning ("The FORALL with index %qs is not used on the "
8849 "left side of the assignment at %L and so might "
8850 "cause multiple assignment to this object",
8851 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8857 /* Resolve WHERE statement in FORALL construct. */
8860 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8861 gfc_expr
**var_expr
)
8866 cblock
= code
->block
;
8869 /* the assignment statement of a WHERE statement, or the first
8870 statement in where-body-construct of a WHERE construct */
8871 cnext
= cblock
->next
;
8876 /* WHERE assignment statement */
8878 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8881 /* WHERE operator assignment statement */
8882 case EXEC_ASSIGN_CALL
:
8883 resolve_call (cnext
);
8884 if (!cnext
->resolved_sym
->attr
.elemental
)
8885 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8886 &cnext
->ext
.actual
->expr
->where
);
8889 /* WHERE or WHERE construct is part of a where-body-construct */
8891 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8895 gfc_error ("Unsupported statement inside WHERE at %L",
8898 /* the next statement within the same where-body-construct */
8899 cnext
= cnext
->next
;
8901 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8902 cblock
= cblock
->block
;
8907 /* Traverse the FORALL body to check whether the following errors exist:
8908 1. For assignment, check if a many-to-one assignment happens.
8909 2. For WHERE statement, check the WHERE body to see if there is any
8910 many-to-one assignment. */
8913 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8917 c
= code
->block
->next
;
8923 case EXEC_POINTER_ASSIGN
:
8924 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8927 case EXEC_ASSIGN_CALL
:
8931 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8932 there is no need to handle it here. */
8936 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8941 /* The next statement in the FORALL body. */
8947 /* Counts the number of iterators needed inside a forall construct, including
8948 nested forall constructs. This is used to allocate the needed memory
8949 in gfc_resolve_forall. */
8952 gfc_count_forall_iterators (gfc_code
*code
)
8954 int max_iters
, sub_iters
, current_iters
;
8955 gfc_forall_iterator
*fa
;
8957 gcc_assert(code
->op
== EXEC_FORALL
);
8961 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8964 code
= code
->block
->next
;
8968 if (code
->op
== EXEC_FORALL
)
8970 sub_iters
= gfc_count_forall_iterators (code
);
8971 if (sub_iters
> max_iters
)
8972 max_iters
= sub_iters
;
8977 return current_iters
+ max_iters
;
8981 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8982 gfc_resolve_forall_body to resolve the FORALL body. */
8985 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8987 static gfc_expr
**var_expr
;
8988 static int total_var
= 0;
8989 static int nvar
= 0;
8991 gfc_forall_iterator
*fa
;
8996 /* Start to resolve a FORALL construct */
8997 if (forall_save
== 0)
8999 /* Count the total number of FORALL index in the nested FORALL
9000 construct in order to allocate the VAR_EXPR with proper size. */
9001 total_var
= gfc_count_forall_iterators (code
);
9003 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9004 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9007 /* The information about FORALL iterator, including FORALL index start, end
9008 and stride. The FORALL index can not appear in start, end or stride. */
9009 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9011 /* Check if any outer FORALL index name is the same as the current
9013 for (i
= 0; i
< nvar
; i
++)
9015 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9017 gfc_error ("An outer FORALL construct already has an index "
9018 "with this name %L", &fa
->var
->where
);
9022 /* Record the current FORALL index. */
9023 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9027 /* No memory leak. */
9028 gcc_assert (nvar
<= total_var
);
9031 /* Resolve the FORALL body. */
9032 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9034 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9035 gfc_resolve_blocks (code
->block
, ns
);
9039 /* Free only the VAR_EXPRs allocated in this frame. */
9040 for (i
= nvar
; i
< tmp
; i
++)
9041 gfc_free_expr (var_expr
[i
]);
9045 /* We are in the outermost FORALL construct. */
9046 gcc_assert (forall_save
== 0);
9048 /* VAR_EXPR is not needed any more. */
9055 /* Resolve a BLOCK construct statement. */
9058 resolve_block_construct (gfc_code
* code
)
9060 /* Resolve the BLOCK's namespace. */
9061 gfc_resolve (code
->ext
.block
.ns
);
9063 /* For an ASSOCIATE block, the associations (and their targets) are already
9064 resolved during resolve_symbol. */
9068 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9072 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9076 for (; b
; b
= b
->block
)
9078 t
= gfc_resolve_expr (b
->expr1
);
9079 if (!gfc_resolve_expr (b
->expr2
))
9085 if (t
&& b
->expr1
!= NULL
9086 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9087 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9094 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9095 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9100 resolve_branch (b
->label1
, b
);
9104 resolve_block_construct (b
);
9108 case EXEC_SELECT_TYPE
:
9112 case EXEC_DO_CONCURRENT
:
9120 case EXEC_OACC_PARALLEL_LOOP
:
9121 case EXEC_OACC_PARALLEL
:
9122 case EXEC_OACC_KERNELS_LOOP
:
9123 case EXEC_OACC_KERNELS
:
9124 case EXEC_OACC_DATA
:
9125 case EXEC_OACC_HOST_DATA
:
9126 case EXEC_OACC_LOOP
:
9127 case EXEC_OACC_UPDATE
:
9128 case EXEC_OACC_WAIT
:
9129 case EXEC_OACC_CACHE
:
9130 case EXEC_OACC_ENTER_DATA
:
9131 case EXEC_OACC_EXIT_DATA
:
9132 case EXEC_OMP_ATOMIC
:
9133 case EXEC_OMP_CRITICAL
:
9134 case EXEC_OMP_DISTRIBUTE
:
9135 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9136 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9137 case EXEC_OMP_DISTRIBUTE_SIMD
:
9139 case EXEC_OMP_DO_SIMD
:
9140 case EXEC_OMP_MASTER
:
9141 case EXEC_OMP_ORDERED
:
9142 case EXEC_OMP_PARALLEL
:
9143 case EXEC_OMP_PARALLEL_DO
:
9144 case EXEC_OMP_PARALLEL_DO_SIMD
:
9145 case EXEC_OMP_PARALLEL_SECTIONS
:
9146 case EXEC_OMP_PARALLEL_WORKSHARE
:
9147 case EXEC_OMP_SECTIONS
:
9149 case EXEC_OMP_SINGLE
:
9150 case EXEC_OMP_TARGET
:
9151 case EXEC_OMP_TARGET_DATA
:
9152 case EXEC_OMP_TARGET_TEAMS
:
9153 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9154 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9155 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9156 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9157 case EXEC_OMP_TARGET_UPDATE
:
9159 case EXEC_OMP_TASKGROUP
:
9160 case EXEC_OMP_TASKWAIT
:
9161 case EXEC_OMP_TASKYIELD
:
9162 case EXEC_OMP_TEAMS
:
9163 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9164 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9165 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9166 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9167 case EXEC_OMP_WORKSHARE
:
9171 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9174 gfc_resolve_code (b
->next
, ns
);
9179 /* Does everything to resolve an ordinary assignment. Returns true
9180 if this is an interface assignment. */
9182 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9191 symbol_attribute attr
;
9193 if (gfc_extend_assign (code
, ns
))
9197 if (code
->op
== EXEC_ASSIGN_CALL
)
9199 lhs
= code
->ext
.actual
->expr
;
9200 rhsptr
= &code
->ext
.actual
->next
->expr
;
9204 gfc_actual_arglist
* args
;
9205 gfc_typebound_proc
* tbp
;
9207 gcc_assert (code
->op
== EXEC_COMPCALL
);
9209 args
= code
->expr1
->value
.compcall
.actual
;
9211 rhsptr
= &args
->next
->expr
;
9213 tbp
= code
->expr1
->value
.compcall
.tbp
;
9214 gcc_assert (!tbp
->is_generic
);
9217 /* Make a temporary rhs when there is a default initializer
9218 and rhs is the same symbol as the lhs. */
9219 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9220 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9221 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9222 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9223 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9232 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9233 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9237 /* Handle the case of a BOZ literal on the RHS. */
9238 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9241 if (warn_surprising
)
9242 gfc_warning (OPT_Wsurprising
,
9243 "BOZ literal at %L is bitwise transferred "
9244 "non-integer symbol %qs", &code
->loc
,
9245 lhs
->symtree
->n
.sym
->name
);
9247 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9249 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9251 if (rc
== ARITH_UNDERFLOW
)
9252 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9253 ". This check can be disabled with the option "
9254 "%<-fno-range-check%>", &rhs
->where
);
9255 else if (rc
== ARITH_OVERFLOW
)
9256 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9257 ". This check can be disabled with the option "
9258 "%<-fno-range-check%>", &rhs
->where
);
9259 else if (rc
== ARITH_NAN
)
9260 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9261 ". This check can be disabled with the option "
9262 "%<-fno-range-check%>", &rhs
->where
);
9267 if (lhs
->ts
.type
== BT_CHARACTER
9268 && warn_character_truncation
)
9270 if (lhs
->ts
.u
.cl
!= NULL
9271 && lhs
->ts
.u
.cl
->length
!= NULL
9272 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9273 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9275 if (rhs
->expr_type
== EXPR_CONSTANT
)
9276 rlen
= rhs
->value
.character
.length
;
9278 else if (rhs
->ts
.u
.cl
!= NULL
9279 && rhs
->ts
.u
.cl
->length
!= NULL
9280 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9281 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9283 if (rlen
&& llen
&& rlen
> llen
)
9284 gfc_warning_now (OPT_Wcharacter_truncation
,
9285 "CHARACTER expression will be truncated "
9286 "in assignment (%d/%d) at %L",
9287 llen
, rlen
, &code
->loc
);
9290 /* Ensure that a vector index expression for the lvalue is evaluated
9291 to a temporary if the lvalue symbol is referenced in it. */
9294 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9295 if (ref
->type
== REF_ARRAY
)
9297 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9298 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9299 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9300 ref
->u
.ar
.start
[n
]))
9302 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9306 if (gfc_pure (NULL
))
9308 if (lhs
->ts
.type
== BT_DERIVED
9309 && lhs
->expr_type
== EXPR_VARIABLE
9310 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9311 && rhs
->expr_type
== EXPR_VARIABLE
9312 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9313 || gfc_is_coindexed (rhs
)))
9316 if (gfc_is_coindexed (rhs
))
9317 gfc_error ("Coindexed expression at %L is assigned to "
9318 "a derived type variable with a POINTER "
9319 "component in a PURE procedure",
9322 gfc_error ("The impure variable at %L is assigned to "
9323 "a derived type variable with a POINTER "
9324 "component in a PURE procedure (12.6)",
9329 /* Fortran 2008, C1283. */
9330 if (gfc_is_coindexed (lhs
))
9332 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9333 "procedure", &rhs
->where
);
9338 if (gfc_implicit_pure (NULL
))
9340 if (lhs
->expr_type
== EXPR_VARIABLE
9341 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9342 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9343 gfc_unset_implicit_pure (NULL
);
9345 if (lhs
->ts
.type
== BT_DERIVED
9346 && lhs
->expr_type
== EXPR_VARIABLE
9347 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9348 && rhs
->expr_type
== EXPR_VARIABLE
9349 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9350 || gfc_is_coindexed (rhs
)))
9351 gfc_unset_implicit_pure (NULL
);
9353 /* Fortran 2008, C1283. */
9354 if (gfc_is_coindexed (lhs
))
9355 gfc_unset_implicit_pure (NULL
);
9358 /* F2008, 7.2.1.2. */
9359 attr
= gfc_expr_attr (lhs
);
9360 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9362 if (attr
.codimension
)
9364 gfc_error ("Assignment to polymorphic coarray at %L is not "
9365 "permitted", &lhs
->where
);
9368 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9369 "polymorphic variable at %L", &lhs
->where
))
9371 if (!flag_realloc_lhs
)
9373 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9374 "requires %<-frealloc-lhs%>", &lhs
->where
);
9378 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9379 "is not yet supported", &lhs
->where
);
9382 else if (lhs
->ts
.type
== BT_CLASS
)
9384 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9385 "assignment at %L - check that there is a matching specific "
9386 "subroutine for '=' operator", &lhs
->where
);
9390 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9392 /* F2008, Section 7.2.1.2. */
9393 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9395 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9396 "component in assignment at %L", &lhs
->where
);
9400 gfc_check_assign (lhs
, rhs
, 1);
9402 /* Assign the 'data' of a class object to a derived type. */
9403 if (lhs
->ts
.type
== BT_DERIVED
9404 && rhs
->ts
.type
== BT_CLASS
)
9405 gfc_add_data_component (rhs
);
9407 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9408 Additionally, insert this code when the RHS is a CAF as we then use the
9409 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9410 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9411 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9413 if (flag_coarray
== GFC_FCOARRAY_LIB
9415 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9416 && code
->expr2
->value
.function
.isym
9417 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9418 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9419 && !gfc_expr_attr (rhs
).allocatable
9420 && !gfc_has_vector_subscript (rhs
))))
9422 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9423 && code
->expr2
->value
.function
.isym
9424 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9425 remove_caf_get_intrinsic (code
->expr2
);
9426 code
->op
= EXEC_CALL
;
9427 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9428 code
->resolved_sym
= code
->symtree
->n
.sym
;
9429 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9430 code
->resolved_sym
->attr
.intrinsic
= 1;
9431 code
->resolved_sym
->attr
.subroutine
= 1;
9432 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9433 gfc_commit_symbol (code
->resolved_sym
);
9434 code
->ext
.actual
= gfc_get_actual_arglist ();
9435 code
->ext
.actual
->expr
= lhs
;
9436 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9437 code
->ext
.actual
->next
->expr
= rhs
;
9446 /* Add a component reference onto an expression. */
9449 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9454 ref
= &((*ref
)->next
);
9455 *ref
= gfc_get_ref ();
9456 (*ref
)->type
= REF_COMPONENT
;
9457 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9458 (*ref
)->u
.c
.component
= c
;
9461 /* Add a full array ref, as necessary. */
9464 gfc_add_full_array_ref (e
, c
->as
);
9465 e
->rank
= c
->as
->rank
;
9470 /* Build an assignment. Keep the argument 'op' for future use, so that
9471 pointer assignments can be made. */
9474 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9475 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9477 gfc_code
*this_code
;
9479 this_code
= gfc_get_code (op
);
9480 this_code
->next
= NULL
;
9481 this_code
->expr1
= gfc_copy_expr (expr1
);
9482 this_code
->expr2
= gfc_copy_expr (expr2
);
9483 this_code
->loc
= loc
;
9486 add_comp_ref (this_code
->expr1
, comp1
);
9487 add_comp_ref (this_code
->expr2
, comp2
);
9494 /* Makes a temporary variable expression based on the characteristics of
9495 a given variable expression. */
9498 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9500 static int serial
= 0;
9501 char name
[GFC_MAX_SYMBOL_LEN
];
9504 gfc_array_ref
*aref
;
9507 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9508 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9509 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9515 /* This function could be expanded to support other expression type
9516 but this is not needed here. */
9517 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9519 /* Obtain the arrayspec for the temporary. */
9522 aref
= gfc_find_array_ref (e
);
9523 if (e
->expr_type
== EXPR_VARIABLE
9524 && e
->symtree
->n
.sym
->as
== aref
->as
)
9528 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9529 if (ref
->type
== REF_COMPONENT
9530 && ref
->u
.c
.component
->as
== aref
->as
)
9538 /* Add the attributes and the arrayspec to the temporary. */
9539 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9540 tmp
->n
.sym
->attr
.function
= 0;
9541 tmp
->n
.sym
->attr
.result
= 0;
9542 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9546 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9549 if (as
->type
== AS_DEFERRED
)
9550 tmp
->n
.sym
->attr
.allocatable
= 1;
9553 tmp
->n
.sym
->attr
.dimension
= 0;
9555 gfc_set_sym_referenced (tmp
->n
.sym
);
9556 gfc_commit_symbol (tmp
->n
.sym
);
9557 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9559 /* Should the lhs be a section, use its array ref for the
9560 temporary expression. */
9561 if (aref
&& aref
->type
!= AR_FULL
)
9563 gfc_free_ref_list (e
->ref
);
9564 e
->ref
= gfc_copy_ref (ref
);
9570 /* Add one line of code to the code chain, making sure that 'head' and
9571 'tail' are appropriately updated. */
9574 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9576 gcc_assert (this_code
);
9578 *head
= *tail
= *this_code
;
9580 *tail
= gfc_append_code (*tail
, *this_code
);
9585 /* Counts the potential number of part array references that would
9586 result from resolution of typebound defined assignments. */
9589 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9592 int c_depth
= 0, t_depth
;
9594 for (c
= derived
->components
; c
; c
= c
->next
)
9596 if ((c
->ts
.type
!= BT_DERIVED
9598 || c
->attr
.allocatable
9599 || c
->attr
.proc_pointer_comp
9600 || c
->attr
.class_pointer
9601 || c
->attr
.proc_pointer
)
9602 && !c
->attr
.defined_assign_comp
)
9605 if (c
->as
&& c_depth
== 0)
9608 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9609 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9614 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9616 return depth
+ c_depth
;
9620 /* Implement 7.2.1.3 of the F08 standard:
9621 "An intrinsic assignment where the variable is of derived type is
9622 performed as if each component of the variable were assigned from the
9623 corresponding component of expr using pointer assignment (7.2.2) for
9624 each pointer component, defined assignment for each nonpointer
9625 nonallocatable component of a type that has a type-bound defined
9626 assignment consistent with the component, intrinsic assignment for
9627 each other nonpointer nonallocatable component, ..."
9629 The pointer assignments are taken care of by the intrinsic
9630 assignment of the structure itself. This function recursively adds
9631 defined assignments where required. The recursion is accomplished
9632 by calling gfc_resolve_code.
9634 When the lhs in a defined assignment has intent INOUT, we need a
9635 temporary for the lhs. In pseudo-code:
9637 ! Only call function lhs once.
9638 if (lhs is not a constant or an variable)
9641 ! Do the intrinsic assignment
9643 ! Now do the defined assignments
9644 do over components with typebound defined assignment [%cmp]
9645 #if one component's assignment procedure is INOUT
9647 #if expr2 non-variable
9653 t1%cmp {defined=} expr2%cmp
9659 expr1%cmp {defined=} expr2%cmp
9663 /* The temporary assignments have to be put on top of the additional
9664 code to avoid the result being changed by the intrinsic assignment.
9666 static int component_assignment_level
= 0;
9667 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9670 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9672 gfc_component
*comp1
, *comp2
;
9673 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9675 int error_count
, depth
;
9677 gfc_get_errors (NULL
, &error_count
);
9679 /* Filter out continuing processing after an error. */
9681 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9682 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9685 /* TODO: Handle more than one part array reference in assignments. */
9686 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9687 (*code
)->expr1
->rank
? 1 : 0);
9690 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9691 "done because multiple part array references would "
9692 "occur in intermediate expressions.", &(*code
)->loc
);
9696 component_assignment_level
++;
9698 /* Create a temporary so that functions get called only once. */
9699 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9700 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9704 /* Assign the rhs to the temporary. */
9705 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9706 this_code
= build_assignment (EXEC_ASSIGN
,
9707 tmp_expr
, (*code
)->expr2
,
9708 NULL
, NULL
, (*code
)->loc
);
9709 /* Add the code and substitute the rhs expression. */
9710 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9711 gfc_free_expr ((*code
)->expr2
);
9712 (*code
)->expr2
= tmp_expr
;
9715 /* Do the intrinsic assignment. This is not needed if the lhs is one
9716 of the temporaries generated here, since the intrinsic assignment
9717 to the final result already does this. */
9718 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9720 this_code
= build_assignment (EXEC_ASSIGN
,
9721 (*code
)->expr1
, (*code
)->expr2
,
9722 NULL
, NULL
, (*code
)->loc
);
9723 add_code_to_chain (&this_code
, &head
, &tail
);
9726 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9727 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9730 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9734 /* The intrinsic assignment does the right thing for pointers
9735 of all kinds and allocatable components. */
9736 if (comp1
->ts
.type
!= BT_DERIVED
9737 || comp1
->attr
.pointer
9738 || comp1
->attr
.allocatable
9739 || comp1
->attr
.proc_pointer_comp
9740 || comp1
->attr
.class_pointer
9741 || comp1
->attr
.proc_pointer
)
9744 /* Make an assigment for this component. */
9745 this_code
= build_assignment (EXEC_ASSIGN
,
9746 (*code
)->expr1
, (*code
)->expr2
,
9747 comp1
, comp2
, (*code
)->loc
);
9749 /* Convert the assignment if there is a defined assignment for
9750 this type. Otherwise, using the call from gfc_resolve_code,
9751 recurse into its components. */
9752 gfc_resolve_code (this_code
, ns
);
9754 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9756 gfc_formal_arglist
*dummy_args
;
9758 /* Check that there is a typebound defined assignment. If not,
9759 then this must be a module defined assignment. We cannot
9760 use the defined_assign_comp attribute here because it must
9761 be this derived type that has the defined assignment and not
9763 if (!(comp1
->ts
.u
.derived
->f2k_derived
9764 && comp1
->ts
.u
.derived
->f2k_derived
9765 ->tb_op
[INTRINSIC_ASSIGN
]))
9767 gfc_free_statements (this_code
);
9772 /* If the first argument of the subroutine has intent INOUT
9773 a temporary must be generated and used instead. */
9774 rsym
= this_code
->resolved_sym
;
9775 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9777 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9779 gfc_code
*temp_code
;
9782 /* Build the temporary required for the assignment and put
9783 it at the head of the generated code. */
9786 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9787 temp_code
= build_assignment (EXEC_ASSIGN
,
9789 NULL
, NULL
, (*code
)->loc
);
9791 /* For allocatable LHS, check whether it is allocated. Note
9792 that allocatable components with defined assignment are
9793 not yet support. See PR 57696. */
9794 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9798 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9799 block
= gfc_get_code (EXEC_IF
);
9800 block
->block
= gfc_get_code (EXEC_IF
);
9802 = gfc_build_intrinsic_call (ns
,
9803 GFC_ISYM_ALLOCATED
, "allocated",
9804 (*code
)->loc
, 1, e
);
9805 block
->block
->next
= temp_code
;
9808 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9811 /* Replace the first actual arg with the component of the
9813 gfc_free_expr (this_code
->ext
.actual
->expr
);
9814 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9815 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9817 /* If the LHS variable is allocatable and wasn't allocated and
9818 the temporary is allocatable, pointer assign the address of
9819 the freshly allocated LHS to the temporary. */
9820 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9821 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9826 cond
= gfc_get_expr ();
9827 cond
->ts
.type
= BT_LOGICAL
;
9828 cond
->ts
.kind
= gfc_default_logical_kind
;
9829 cond
->expr_type
= EXPR_OP
;
9830 cond
->where
= (*code
)->loc
;
9831 cond
->value
.op
.op
= INTRINSIC_NOT
;
9832 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9833 GFC_ISYM_ALLOCATED
, "allocated",
9834 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9835 block
= gfc_get_code (EXEC_IF
);
9836 block
->block
= gfc_get_code (EXEC_IF
);
9837 block
->block
->expr1
= cond
;
9838 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9840 NULL
, NULL
, (*code
)->loc
);
9841 add_code_to_chain (&block
, &head
, &tail
);
9845 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9847 /* Don't add intrinsic assignments since they are already
9848 effected by the intrinsic assignment of the structure. */
9849 gfc_free_statements (this_code
);
9854 add_code_to_chain (&this_code
, &head
, &tail
);
9858 /* Transfer the value to the final result. */
9859 this_code
= build_assignment (EXEC_ASSIGN
,
9861 comp1
, comp2
, (*code
)->loc
);
9862 add_code_to_chain (&this_code
, &head
, &tail
);
9866 /* Put the temporary assignments at the top of the generated code. */
9867 if (tmp_head
&& component_assignment_level
== 1)
9869 gfc_append_code (tmp_head
, head
);
9871 tmp_head
= tmp_tail
= NULL
;
9874 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9875 // not accidentally deallocated. Hence, nullify t1.
9876 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9877 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9883 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9884 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9885 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9886 block
= gfc_get_code (EXEC_IF
);
9887 block
->block
= gfc_get_code (EXEC_IF
);
9888 block
->block
->expr1
= cond
;
9889 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9890 t1
, gfc_get_null_expr (&(*code
)->loc
),
9891 NULL
, NULL
, (*code
)->loc
);
9892 gfc_append_code (tail
, block
);
9896 /* Now attach the remaining code chain to the input code. Step on
9897 to the end of the new code since resolution is complete. */
9898 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9899 tail
->next
= (*code
)->next
;
9900 /* Overwrite 'code' because this would place the intrinsic assignment
9901 before the temporary for the lhs is created. */
9902 gfc_free_expr ((*code
)->expr1
);
9903 gfc_free_expr ((*code
)->expr2
);
9909 component_assignment_level
--;
9913 /* Given a block of code, recursively resolve everything pointed to by this
9917 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9919 int omp_workshare_save
;
9920 int forall_save
, do_concurrent_save
;
9924 frame
.prev
= cs_base
;
9928 find_reachable_labels (code
);
9930 for (; code
; code
= code
->next
)
9932 frame
.current
= code
;
9933 forall_save
= forall_flag
;
9934 do_concurrent_save
= gfc_do_concurrent_flag
;
9936 if (code
->op
== EXEC_FORALL
)
9939 gfc_resolve_forall (code
, ns
, forall_save
);
9942 else if (code
->block
)
9944 omp_workshare_save
= -1;
9947 case EXEC_OACC_PARALLEL_LOOP
:
9948 case EXEC_OACC_PARALLEL
:
9949 case EXEC_OACC_KERNELS_LOOP
:
9950 case EXEC_OACC_KERNELS
:
9951 case EXEC_OACC_DATA
:
9952 case EXEC_OACC_HOST_DATA
:
9953 case EXEC_OACC_LOOP
:
9954 gfc_resolve_oacc_blocks (code
, ns
);
9956 case EXEC_OMP_PARALLEL_WORKSHARE
:
9957 omp_workshare_save
= omp_workshare_flag
;
9958 omp_workshare_flag
= 1;
9959 gfc_resolve_omp_parallel_blocks (code
, ns
);
9961 case EXEC_OMP_PARALLEL
:
9962 case EXEC_OMP_PARALLEL_DO
:
9963 case EXEC_OMP_PARALLEL_DO_SIMD
:
9964 case EXEC_OMP_PARALLEL_SECTIONS
:
9965 case EXEC_OMP_TARGET_TEAMS
:
9966 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9967 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9968 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9969 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9971 case EXEC_OMP_TEAMS
:
9972 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9973 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9974 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9975 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9976 omp_workshare_save
= omp_workshare_flag
;
9977 omp_workshare_flag
= 0;
9978 gfc_resolve_omp_parallel_blocks (code
, ns
);
9980 case EXEC_OMP_DISTRIBUTE
:
9981 case EXEC_OMP_DISTRIBUTE_SIMD
:
9983 case EXEC_OMP_DO_SIMD
:
9985 gfc_resolve_omp_do_blocks (code
, ns
);
9987 case EXEC_SELECT_TYPE
:
9988 /* Blocks are handled in resolve_select_type because we have
9989 to transform the SELECT TYPE into ASSOCIATE first. */
9991 case EXEC_DO_CONCURRENT
:
9992 gfc_do_concurrent_flag
= 1;
9993 gfc_resolve_blocks (code
->block
, ns
);
9994 gfc_do_concurrent_flag
= 2;
9996 case EXEC_OMP_WORKSHARE
:
9997 omp_workshare_save
= omp_workshare_flag
;
9998 omp_workshare_flag
= 1;
10001 gfc_resolve_blocks (code
->block
, ns
);
10005 if (omp_workshare_save
!= -1)
10006 omp_workshare_flag
= omp_workshare_save
;
10010 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10011 t
= gfc_resolve_expr (code
->expr1
);
10012 forall_flag
= forall_save
;
10013 gfc_do_concurrent_flag
= do_concurrent_save
;
10015 if (!gfc_resolve_expr (code
->expr2
))
10018 if (code
->op
== EXEC_ALLOCATE
10019 && !gfc_resolve_expr (code
->expr3
))
10025 case EXEC_END_BLOCK
:
10026 case EXEC_END_NESTED_BLOCK
:
10030 case EXEC_ERROR_STOP
:
10032 case EXEC_CONTINUE
:
10034 case EXEC_ASSIGN_CALL
:
10037 case EXEC_CRITICAL
:
10038 resolve_critical (code
);
10041 case EXEC_SYNC_ALL
:
10042 case EXEC_SYNC_IMAGES
:
10043 case EXEC_SYNC_MEMORY
:
10044 resolve_sync (code
);
10049 resolve_lock_unlock (code
);
10053 /* Keep track of which entry we are up to. */
10054 current_entry_id
= code
->ext
.entry
->id
;
10058 resolve_where (code
, NULL
);
10062 if (code
->expr1
!= NULL
)
10064 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10065 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10066 "INTEGER variable", &code
->expr1
->where
);
10067 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10068 gfc_error ("Variable %qs has not been assigned a target "
10069 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10070 &code
->expr1
->where
);
10073 resolve_branch (code
->label1
, code
);
10077 if (code
->expr1
!= NULL
10078 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10079 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10080 "INTEGER return specifier", &code
->expr1
->where
);
10083 case EXEC_INIT_ASSIGN
:
10084 case EXEC_END_PROCEDURE
:
10091 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10093 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10094 && code
->expr1
->value
.function
.isym
10095 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10096 remove_caf_get_intrinsic (code
->expr1
);
10098 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10102 if (resolve_ordinary_assign (code
, ns
))
10104 if (code
->op
== EXEC_COMPCALL
)
10110 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10111 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10112 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10113 generate_component_assignments (&code
, ns
);
10117 case EXEC_LABEL_ASSIGN
:
10118 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10119 gfc_error ("Label %d referenced at %L is never defined",
10120 code
->label1
->value
, &code
->label1
->where
);
10122 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10123 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10124 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10125 != gfc_default_integer_kind
10126 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10127 gfc_error ("ASSIGN statement at %L requires a scalar "
10128 "default INTEGER variable", &code
->expr1
->where
);
10131 case EXEC_POINTER_ASSIGN
:
10138 /* This is both a variable definition and pointer assignment
10139 context, so check both of them. For rank remapping, a final
10140 array ref may be present on the LHS and fool gfc_expr_attr
10141 used in gfc_check_vardef_context. Remove it. */
10142 e
= remove_last_array_ref (code
->expr1
);
10143 t
= gfc_check_vardef_context (e
, true, false, false,
10144 _("pointer assignment"));
10146 t
= gfc_check_vardef_context (e
, false, false, false,
10147 _("pointer assignment"));
10152 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10156 case EXEC_ARITHMETIC_IF
:
10158 && code
->expr1
->ts
.type
!= BT_INTEGER
10159 && code
->expr1
->ts
.type
!= BT_REAL
)
10160 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10161 "expression", &code
->expr1
->where
);
10163 resolve_branch (code
->label1
, code
);
10164 resolve_branch (code
->label2
, code
);
10165 resolve_branch (code
->label3
, code
);
10169 if (t
&& code
->expr1
!= NULL
10170 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10171 || code
->expr1
->rank
!= 0))
10172 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10173 &code
->expr1
->where
);
10178 resolve_call (code
);
10181 case EXEC_COMPCALL
:
10183 resolve_typebound_subroutine (code
);
10186 case EXEC_CALL_PPC
:
10187 resolve_ppc_call (code
);
10191 /* Select is complicated. Also, a SELECT construct could be
10192 a transformed computed GOTO. */
10193 resolve_select (code
, false);
10196 case EXEC_SELECT_TYPE
:
10197 resolve_select_type (code
, ns
);
10201 resolve_block_construct (code
);
10205 if (code
->ext
.iterator
!= NULL
)
10207 gfc_iterator
*iter
= code
->ext
.iterator
;
10208 if (gfc_resolve_iterator (iter
, true, false))
10209 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10213 case EXEC_DO_WHILE
:
10214 if (code
->expr1
== NULL
)
10215 gfc_internal_error ("gfc_resolve_code(): No expression on "
10218 && (code
->expr1
->rank
!= 0
10219 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10220 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10221 "a scalar LOGICAL expression", &code
->expr1
->where
);
10224 case EXEC_ALLOCATE
:
10226 resolve_allocate_deallocate (code
, "ALLOCATE");
10230 case EXEC_DEALLOCATE
:
10232 resolve_allocate_deallocate (code
, "DEALLOCATE");
10237 if (!gfc_resolve_open (code
->ext
.open
))
10240 resolve_branch (code
->ext
.open
->err
, code
);
10244 if (!gfc_resolve_close (code
->ext
.close
))
10247 resolve_branch (code
->ext
.close
->err
, code
);
10250 case EXEC_BACKSPACE
:
10254 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10257 resolve_branch (code
->ext
.filepos
->err
, code
);
10261 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10264 resolve_branch (code
->ext
.inquire
->err
, code
);
10267 case EXEC_IOLENGTH
:
10268 gcc_assert (code
->ext
.inquire
!= NULL
);
10269 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10272 resolve_branch (code
->ext
.inquire
->err
, code
);
10276 if (!gfc_resolve_wait (code
->ext
.wait
))
10279 resolve_branch (code
->ext
.wait
->err
, code
);
10280 resolve_branch (code
->ext
.wait
->end
, code
);
10281 resolve_branch (code
->ext
.wait
->eor
, code
);
10286 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10289 resolve_branch (code
->ext
.dt
->err
, code
);
10290 resolve_branch (code
->ext
.dt
->end
, code
);
10291 resolve_branch (code
->ext
.dt
->eor
, code
);
10294 case EXEC_TRANSFER
:
10295 resolve_transfer (code
);
10298 case EXEC_DO_CONCURRENT
:
10300 resolve_forall_iterators (code
->ext
.forall_iterator
);
10302 if (code
->expr1
!= NULL
10303 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10304 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10305 "expression", &code
->expr1
->where
);
10308 case EXEC_OACC_PARALLEL_LOOP
:
10309 case EXEC_OACC_PARALLEL
:
10310 case EXEC_OACC_KERNELS_LOOP
:
10311 case EXEC_OACC_KERNELS
:
10312 case EXEC_OACC_DATA
:
10313 case EXEC_OACC_HOST_DATA
:
10314 case EXEC_OACC_LOOP
:
10315 case EXEC_OACC_UPDATE
:
10316 case EXEC_OACC_WAIT
:
10317 case EXEC_OACC_CACHE
:
10318 case EXEC_OACC_ENTER_DATA
:
10319 case EXEC_OACC_EXIT_DATA
:
10320 gfc_resolve_oacc_directive (code
, ns
);
10323 case EXEC_OMP_ATOMIC
:
10324 case EXEC_OMP_BARRIER
:
10325 case EXEC_OMP_CANCEL
:
10326 case EXEC_OMP_CANCELLATION_POINT
:
10327 case EXEC_OMP_CRITICAL
:
10328 case EXEC_OMP_FLUSH
:
10329 case EXEC_OMP_DISTRIBUTE
:
10330 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10331 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10332 case EXEC_OMP_DISTRIBUTE_SIMD
:
10334 case EXEC_OMP_DO_SIMD
:
10335 case EXEC_OMP_MASTER
:
10336 case EXEC_OMP_ORDERED
:
10337 case EXEC_OMP_SECTIONS
:
10338 case EXEC_OMP_SIMD
:
10339 case EXEC_OMP_SINGLE
:
10340 case EXEC_OMP_TARGET
:
10341 case EXEC_OMP_TARGET_DATA
:
10342 case EXEC_OMP_TARGET_TEAMS
:
10343 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10344 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10345 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10346 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10347 case EXEC_OMP_TARGET_UPDATE
:
10348 case EXEC_OMP_TASK
:
10349 case EXEC_OMP_TASKGROUP
:
10350 case EXEC_OMP_TASKWAIT
:
10351 case EXEC_OMP_TASKYIELD
:
10352 case EXEC_OMP_TEAMS
:
10353 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10354 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10355 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10356 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10357 case EXEC_OMP_WORKSHARE
:
10358 gfc_resolve_omp_directive (code
, ns
);
10361 case EXEC_OMP_PARALLEL
:
10362 case EXEC_OMP_PARALLEL_DO
:
10363 case EXEC_OMP_PARALLEL_DO_SIMD
:
10364 case EXEC_OMP_PARALLEL_SECTIONS
:
10365 case EXEC_OMP_PARALLEL_WORKSHARE
:
10366 omp_workshare_save
= omp_workshare_flag
;
10367 omp_workshare_flag
= 0;
10368 gfc_resolve_omp_directive (code
, ns
);
10369 omp_workshare_flag
= omp_workshare_save
;
10373 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10377 cs_base
= frame
.prev
;
10381 /* Resolve initial values and make sure they are compatible with
10385 resolve_values (gfc_symbol
*sym
)
10389 if (sym
->value
== NULL
)
10392 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10393 t
= resolve_structure_cons (sym
->value
, 1);
10395 t
= gfc_resolve_expr (sym
->value
);
10400 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10404 /* Verify any BIND(C) derived types in the namespace so we can report errors
10405 for them once, rather than for each variable declared of that type. */
10408 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10410 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10411 && derived_sym
->attr
.is_bind_c
== 1)
10412 verify_bind_c_derived_type (derived_sym
);
10418 /* Verify that any binding labels used in a given namespace do not collide
10419 with the names or binding labels of any global symbols. Multiple INTERFACE
10420 for the same procedure are permitted. */
10423 gfc_verify_binding_labels (gfc_symbol
*sym
)
10426 const char *module
;
10428 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10429 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10432 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10435 module
= sym
->module
;
10436 else if (sym
->ns
&& sym
->ns
->proc_name
10437 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10438 module
= sym
->ns
->proc_name
->name
;
10439 else if (sym
->ns
&& sym
->ns
->parent
10440 && sym
->ns
&& sym
->ns
->parent
->proc_name
10441 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10442 module
= sym
->ns
->parent
->proc_name
->name
;
10448 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10451 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10452 gsym
->where
= sym
->declared_at
;
10453 gsym
->sym_name
= sym
->name
;
10454 gsym
->binding_label
= sym
->binding_label
;
10455 gsym
->ns
= sym
->ns
;
10456 gsym
->mod_name
= module
;
10457 if (sym
->attr
.function
)
10458 gsym
->type
= GSYM_FUNCTION
;
10459 else if (sym
->attr
.subroutine
)
10460 gsym
->type
= GSYM_SUBROUTINE
;
10461 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10462 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10466 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10468 gfc_error_1 ("Variable %s with binding label %s at %L uses the same global "
10469 "identifier as entity at %L", sym
->name
,
10470 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10471 /* Clear the binding label to prevent checking multiple times. */
10472 sym
->binding_label
= NULL
;
10475 else if (sym
->attr
.flavor
== FL_VARIABLE
10476 && (strcmp (module
, gsym
->mod_name
) != 0
10477 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10479 /* This can only happen if the variable is defined in a module - if it
10480 isn't the same module, reject it. */
10481 gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses "
10482 "the same global identifier as entity at %L from module %s",
10483 sym
->name
, module
, sym
->binding_label
,
10484 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10485 sym
->binding_label
= NULL
;
10487 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10488 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10489 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10490 && sym
!= gsym
->ns
->proc_name
10491 && (module
!= gsym
->mod_name
10492 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10493 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10495 /* Print an error if the procedure is defined multiple times; we have to
10496 exclude references to the same procedure via module association or
10497 multiple checks for the same procedure. */
10498 gfc_error_1 ("Procedure %s with binding label %s at %L uses the same "
10499 "global identifier as entity at %L", sym
->name
,
10500 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10501 sym
->binding_label
= NULL
;
10506 /* Resolve an index expression. */
10509 resolve_index_expr (gfc_expr
*e
)
10511 if (!gfc_resolve_expr (e
))
10514 if (!gfc_simplify_expr (e
, 0))
10517 if (!gfc_specification_expr (e
))
10524 /* Resolve a charlen structure. */
10527 resolve_charlen (gfc_charlen
*cl
)
10530 bool saved_specification_expr
;
10536 saved_specification_expr
= specification_expr
;
10537 specification_expr
= true;
10539 if (cl
->length_from_typespec
)
10541 if (!gfc_resolve_expr (cl
->length
))
10543 specification_expr
= saved_specification_expr
;
10547 if (!gfc_simplify_expr (cl
->length
, 0))
10549 specification_expr
= saved_specification_expr
;
10556 if (!resolve_index_expr (cl
->length
))
10558 specification_expr
= saved_specification_expr
;
10563 /* "If the character length parameter value evaluates to a negative
10564 value, the length of character entities declared is zero." */
10565 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10567 if (warn_surprising
)
10568 gfc_warning_now (OPT_Wsurprising
,
10569 "CHARACTER variable at %L has negative length %d,"
10570 " the length has been set to zero",
10571 &cl
->length
->where
, i
);
10572 gfc_replace_expr (cl
->length
,
10573 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10576 /* Check that the character length is not too large. */
10577 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10578 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10579 && cl
->length
->ts
.type
== BT_INTEGER
10580 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10582 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10583 specification_expr
= saved_specification_expr
;
10587 specification_expr
= saved_specification_expr
;
10592 /* Test for non-constant shape arrays. */
10595 is_non_constant_shape_array (gfc_symbol
*sym
)
10601 not_constant
= false;
10602 if (sym
->as
!= NULL
)
10604 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10605 has not been simplified; parameter array references. Do the
10606 simplification now. */
10607 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10609 e
= sym
->as
->lower
[i
];
10610 if (e
&& (!resolve_index_expr(e
)
10611 || !gfc_is_constant_expr (e
)))
10612 not_constant
= true;
10613 e
= sym
->as
->upper
[i
];
10614 if (e
&& (!resolve_index_expr(e
)
10615 || !gfc_is_constant_expr (e
)))
10616 not_constant
= true;
10619 return not_constant
;
10622 /* Given a symbol and an initialization expression, add code to initialize
10623 the symbol to the function entry. */
10625 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10629 gfc_namespace
*ns
= sym
->ns
;
10631 /* Search for the function namespace if this is a contained
10632 function without an explicit result. */
10633 if (sym
->attr
.function
&& sym
== sym
->result
10634 && sym
->name
!= sym
->ns
->proc_name
->name
)
10636 ns
= ns
->contained
;
10637 for (;ns
; ns
= ns
->sibling
)
10638 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10644 gfc_free_expr (init
);
10648 /* Build an l-value expression for the result. */
10649 lval
= gfc_lval_expr_from_sym (sym
);
10651 /* Add the code at scope entry. */
10652 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10653 init_st
->next
= ns
->code
;
10654 ns
->code
= init_st
;
10656 /* Assign the default initializer to the l-value. */
10657 init_st
->loc
= sym
->declared_at
;
10658 init_st
->expr1
= lval
;
10659 init_st
->expr2
= init
;
10662 /* Assign the default initializer to a derived type variable or result. */
10665 apply_default_init (gfc_symbol
*sym
)
10667 gfc_expr
*init
= NULL
;
10669 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10672 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10673 init
= gfc_default_initializer (&sym
->ts
);
10675 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10678 build_init_assign (sym
, init
);
10679 sym
->attr
.referenced
= 1;
10682 /* Build an initializer for a local integer, real, complex, logical, or
10683 character variable, based on the command line flags finit-local-zero,
10684 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10685 null if the symbol should not have a default initialization. */
10687 build_default_init_expr (gfc_symbol
*sym
)
10690 gfc_expr
*init_expr
;
10693 /* These symbols should never have a default initialization. */
10694 if (sym
->attr
.allocatable
10695 || sym
->attr
.external
10697 || sym
->attr
.pointer
10698 || sym
->attr
.in_equivalence
10699 || sym
->attr
.in_common
10702 || sym
->attr
.cray_pointee
10703 || sym
->attr
.cray_pointer
10707 /* Now we'll try to build an initializer expression. */
10708 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10709 &sym
->declared_at
);
10711 /* We will only initialize integers, reals, complex, logicals, and
10712 characters, and only if the corresponding command-line flags
10713 were set. Otherwise, we free init_expr and return null. */
10714 switch (sym
->ts
.type
)
10717 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10718 mpz_set_si (init_expr
->value
.integer
,
10719 gfc_option
.flag_init_integer_value
);
10722 gfc_free_expr (init_expr
);
10728 switch (flag_init_real
)
10730 case GFC_INIT_REAL_SNAN
:
10731 init_expr
->is_snan
= 1;
10732 /* Fall through. */
10733 case GFC_INIT_REAL_NAN
:
10734 mpfr_set_nan (init_expr
->value
.real
);
10737 case GFC_INIT_REAL_INF
:
10738 mpfr_set_inf (init_expr
->value
.real
, 1);
10741 case GFC_INIT_REAL_NEG_INF
:
10742 mpfr_set_inf (init_expr
->value
.real
, -1);
10745 case GFC_INIT_REAL_ZERO
:
10746 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10750 gfc_free_expr (init_expr
);
10757 switch (flag_init_real
)
10759 case GFC_INIT_REAL_SNAN
:
10760 init_expr
->is_snan
= 1;
10761 /* Fall through. */
10762 case GFC_INIT_REAL_NAN
:
10763 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10764 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10767 case GFC_INIT_REAL_INF
:
10768 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10769 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10772 case GFC_INIT_REAL_NEG_INF
:
10773 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10774 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10777 case GFC_INIT_REAL_ZERO
:
10778 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10782 gfc_free_expr (init_expr
);
10789 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10790 init_expr
->value
.logical
= 0;
10791 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10792 init_expr
->value
.logical
= 1;
10795 gfc_free_expr (init_expr
);
10801 /* For characters, the length must be constant in order to
10802 create a default initializer. */
10803 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10804 && sym
->ts
.u
.cl
->length
10805 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10807 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10808 init_expr
->value
.character
.length
= char_len
;
10809 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10810 for (i
= 0; i
< char_len
; i
++)
10811 init_expr
->value
.character
.string
[i
]
10812 = (unsigned char) gfc_option
.flag_init_character_value
;
10816 gfc_free_expr (init_expr
);
10819 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10820 && sym
->ts
.u
.cl
->length
&& flag_max_stack_var_size
!= 0)
10822 gfc_actual_arglist
*arg
;
10823 init_expr
= gfc_get_expr ();
10824 init_expr
->where
= sym
->declared_at
;
10825 init_expr
->ts
= sym
->ts
;
10826 init_expr
->expr_type
= EXPR_FUNCTION
;
10827 init_expr
->value
.function
.isym
=
10828 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10829 init_expr
->value
.function
.name
= "repeat";
10830 arg
= gfc_get_actual_arglist ();
10831 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10833 arg
->expr
->value
.character
.string
[0]
10834 = gfc_option
.flag_init_character_value
;
10835 arg
->next
= gfc_get_actual_arglist ();
10836 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10837 init_expr
->value
.function
.actual
= arg
;
10842 gfc_free_expr (init_expr
);
10848 /* Add an initialization expression to a local variable. */
10850 apply_default_init_local (gfc_symbol
*sym
)
10852 gfc_expr
*init
= NULL
;
10854 /* The symbol should be a variable or a function return value. */
10855 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10856 || (sym
->attr
.function
&& sym
->result
!= sym
))
10859 /* Try to build the initializer expression. If we can't initialize
10860 this symbol, then init will be NULL. */
10861 init
= build_default_init_expr (sym
);
10865 /* For saved variables, we don't want to add an initializer at function
10866 entry, so we just add a static initializer. Note that automatic variables
10867 are stack allocated even with -fno-automatic; we have also to exclude
10868 result variable, which are also nonstatic. */
10869 if (sym
->attr
.save
|| sym
->ns
->save_all
10870 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
10871 && !sym
->ns
->proc_name
->attr
.recursive
10872 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10874 /* Don't clobber an existing initializer! */
10875 gcc_assert (sym
->value
== NULL
);
10880 build_init_assign (sym
, init
);
10884 /* Resolution of common features of flavors variable and procedure. */
10887 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10889 gfc_array_spec
*as
;
10891 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10892 as
= CLASS_DATA (sym
)->as
;
10896 /* Constraints on deferred shape variable. */
10897 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10899 bool pointer
, allocatable
, dimension
;
10901 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10903 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10904 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10905 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10909 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10910 allocatable
= sym
->attr
.allocatable
;
10911 dimension
= sym
->attr
.dimension
;
10916 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10918 gfc_error ("Allocatable array %qs at %L must have a deferred "
10919 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10922 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10923 "%qs at %L may not be ALLOCATABLE",
10924 sym
->name
, &sym
->declared_at
))
10928 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10930 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
10931 "assumed rank", sym
->name
, &sym
->declared_at
);
10937 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10938 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10940 gfc_error ("Array %qs at %L cannot have a deferred shape",
10941 sym
->name
, &sym
->declared_at
);
10946 /* Constraints on polymorphic variables. */
10947 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10950 if (sym
->attr
.class_ok
10951 && !sym
->attr
.select_type_temporary
10952 && !UNLIMITED_POLY (sym
)
10953 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10955 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
10956 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10957 &sym
->declared_at
);
10962 /* Assume that use associated symbols were checked in the module ns.
10963 Class-variables that are associate-names are also something special
10964 and excepted from the test. */
10965 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10967 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
10968 "or pointer", sym
->name
, &sym
->declared_at
);
10977 /* Additional checks for symbols with flavor variable and derived
10978 type. To be called from resolve_fl_variable. */
10981 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10983 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10985 /* Check to see if a derived type is blocked from being host
10986 associated by the presence of another class I symbol in the same
10987 namespace. 14.6.1.3 of the standard and the discussion on
10988 comp.lang.fortran. */
10989 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10990 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10993 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10994 if (s
&& s
->attr
.generic
)
10995 s
= gfc_find_dt_in_generic (s
);
10996 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10998 gfc_error_1 ("The type '%s' cannot be host associated at %L "
10999 "because it is blocked by an incompatible object "
11000 "of the same name declared at %L",
11001 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11007 /* 4th constraint in section 11.3: "If an object of a type for which
11008 component-initialization is specified (R429) appears in the
11009 specification-part of a module and does not have the ALLOCATABLE
11010 or POINTER attribute, the object shall have the SAVE attribute."
11012 The check for initializers is performed with
11013 gfc_has_default_initializer because gfc_default_initializer generates
11014 a hidden default for allocatable components. */
11015 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11016 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11017 && !sym
->ns
->save_all
&& !sym
->attr
.save
11018 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11019 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11020 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11021 "%qs at %L, needed due to the default "
11022 "initialization", sym
->name
, &sym
->declared_at
))
11025 /* Assign default initializer. */
11026 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11027 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11029 sym
->value
= gfc_default_initializer (&sym
->ts
);
11036 /* Resolve symbols with flavor variable. */
11039 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11041 int no_init_flag
, automatic_flag
;
11043 const char *auto_save_msg
;
11044 bool saved_specification_expr
;
11046 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11049 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11052 /* Set this flag to check that variables are parameters of all entries.
11053 This check is effected by the call to gfc_resolve_expr through
11054 is_non_constant_shape_array. */
11055 saved_specification_expr
= specification_expr
;
11056 specification_expr
= true;
11058 if (sym
->ns
->proc_name
11059 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11060 || sym
->ns
->proc_name
->attr
.is_main_program
)
11061 && !sym
->attr
.use_assoc
11062 && !sym
->attr
.allocatable
11063 && !sym
->attr
.pointer
11064 && is_non_constant_shape_array (sym
))
11066 /* The shape of a main program or module array needs to be
11068 gfc_error ("The module or main program array '%s' at %L must "
11069 "have constant shape", sym
->name
, &sym
->declared_at
);
11070 specification_expr
= saved_specification_expr
;
11074 /* Constraints on deferred type parameter. */
11075 if (sym
->ts
.deferred
11076 && !(sym
->attr
.pointer
11077 || sym
->attr
.allocatable
11078 || sym
->attr
.omp_udr_artificial_var
))
11080 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11081 "requires either the pointer or allocatable attribute",
11082 sym
->name
, &sym
->declared_at
);
11083 specification_expr
= saved_specification_expr
;
11087 if (sym
->ts
.type
== BT_CHARACTER
)
11089 /* Make sure that character string variables with assumed length are
11090 dummy arguments. */
11091 e
= sym
->ts
.u
.cl
->length
;
11092 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11093 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11094 && !sym
->attr
.omp_udr_artificial_var
)
11096 gfc_error ("Entity with assumed character length at %L must be a "
11097 "dummy argument or a PARAMETER", &sym
->declared_at
);
11098 specification_expr
= saved_specification_expr
;
11102 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11104 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11105 specification_expr
= saved_specification_expr
;
11109 if (!gfc_is_constant_expr (e
)
11110 && !(e
->expr_type
== EXPR_VARIABLE
11111 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11113 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11114 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11115 || sym
->ns
->proc_name
->attr
.is_main_program
))
11117 gfc_error ("'%s' at %L must have constant character length "
11118 "in this context", sym
->name
, &sym
->declared_at
);
11119 specification_expr
= saved_specification_expr
;
11122 if (sym
->attr
.in_common
)
11124 gfc_error ("COMMON variable %qs at %L must have constant "
11125 "character length", sym
->name
, &sym
->declared_at
);
11126 specification_expr
= saved_specification_expr
;
11132 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11133 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11135 /* Determine if the symbol may not have an initializer. */
11136 no_init_flag
= automatic_flag
= 0;
11137 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11138 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11140 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11141 && is_non_constant_shape_array (sym
))
11143 no_init_flag
= automatic_flag
= 1;
11145 /* Also, they must not have the SAVE attribute.
11146 SAVE_IMPLICIT is checked below. */
11147 if (sym
->as
&& sym
->attr
.codimension
)
11149 int corank
= sym
->as
->corank
;
11150 sym
->as
->corank
= 0;
11151 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11152 sym
->as
->corank
= corank
;
11154 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11156 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11157 specification_expr
= saved_specification_expr
;
11162 /* Ensure that any initializer is simplified. */
11164 gfc_simplify_expr (sym
->value
, 1);
11166 /* Reject illegal initializers. */
11167 if (!sym
->mark
&& sym
->value
)
11169 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11170 && CLASS_DATA (sym
)->attr
.allocatable
))
11171 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11172 sym
->name
, &sym
->declared_at
);
11173 else if (sym
->attr
.external
)
11174 gfc_error ("External %qs at %L cannot have an initializer",
11175 sym
->name
, &sym
->declared_at
);
11176 else if (sym
->attr
.dummy
11177 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11178 gfc_error ("Dummy %qs at %L cannot have an initializer",
11179 sym
->name
, &sym
->declared_at
);
11180 else if (sym
->attr
.intrinsic
)
11181 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11182 sym
->name
, &sym
->declared_at
);
11183 else if (sym
->attr
.result
)
11184 gfc_error ("Function result %qs at %L cannot have an initializer",
11185 sym
->name
, &sym
->declared_at
);
11186 else if (automatic_flag
)
11187 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11188 sym
->name
, &sym
->declared_at
);
11190 goto no_init_error
;
11191 specification_expr
= saved_specification_expr
;
11196 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11198 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11199 specification_expr
= saved_specification_expr
;
11203 specification_expr
= saved_specification_expr
;
11208 /* Resolve a procedure. */
11211 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11213 gfc_formal_arglist
*arg
;
11215 if (sym
->attr
.function
11216 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11219 if (sym
->ts
.type
== BT_CHARACTER
)
11221 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11223 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11224 && !resolve_charlen (cl
))
11227 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11228 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11230 gfc_error ("Character-valued statement function %qs at %L must "
11231 "have constant length", sym
->name
, &sym
->declared_at
);
11236 /* Ensure that derived type for are not of a private type. Internal
11237 module procedures are excluded by 2.2.3.3 - i.e., they are not
11238 externally accessible and can access all the objects accessible in
11240 if (!(sym
->ns
->parent
11241 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11242 && gfc_check_symbol_access (sym
))
11244 gfc_interface
*iface
;
11246 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11249 && arg
->sym
->ts
.type
== BT_DERIVED
11250 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11251 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11252 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11253 "and cannot be a dummy argument"
11254 " of %qs, which is PUBLIC at %L",
11255 arg
->sym
->name
, sym
->name
,
11256 &sym
->declared_at
))
11258 /* Stop this message from recurring. */
11259 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11264 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11265 PRIVATE to the containing module. */
11266 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11268 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11271 && arg
->sym
->ts
.type
== BT_DERIVED
11272 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11273 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11274 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11275 "PUBLIC interface %qs at %L "
11276 "takes dummy arguments of %qs which "
11277 "is PRIVATE", iface
->sym
->name
,
11278 sym
->name
, &iface
->sym
->declared_at
,
11279 gfc_typename(&arg
->sym
->ts
)))
11281 /* Stop this message from recurring. */
11282 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11289 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11290 && !sym
->attr
.proc_pointer
)
11292 gfc_error ("Function %qs at %L cannot have an initializer",
11293 sym
->name
, &sym
->declared_at
);
11297 /* An external symbol may not have an initializer because it is taken to be
11298 a procedure. Exception: Procedure Pointers. */
11299 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11301 gfc_error ("External object %qs at %L may not have an initializer",
11302 sym
->name
, &sym
->declared_at
);
11306 /* An elemental function is required to return a scalar 12.7.1 */
11307 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11309 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11310 "result", sym
->name
, &sym
->declared_at
);
11311 /* Reset so that the error only occurs once. */
11312 sym
->attr
.elemental
= 0;
11316 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11317 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11319 gfc_error ("Statement function %qs at %L may not have pointer or "
11320 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11324 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11325 char-len-param shall not be array-valued, pointer-valued, recursive
11326 or pure. ....snip... A character value of * may only be used in the
11327 following ways: (i) Dummy arg of procedure - dummy associates with
11328 actual length; (ii) To declare a named constant; or (iii) External
11329 function - but length must be declared in calling scoping unit. */
11330 if (sym
->attr
.function
11331 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11332 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11334 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11335 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11337 if (sym
->as
&& sym
->as
->rank
)
11338 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11339 "array-valued", sym
->name
, &sym
->declared_at
);
11341 if (sym
->attr
.pointer
)
11342 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11343 "pointer-valued", sym
->name
, &sym
->declared_at
);
11345 if (sym
->attr
.pure
)
11346 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11347 "pure", sym
->name
, &sym
->declared_at
);
11349 if (sym
->attr
.recursive
)
11350 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11351 "recursive", sym
->name
, &sym
->declared_at
);
11356 /* Appendix B.2 of the standard. Contained functions give an
11357 error anyway. Deferred character length is an F2003 feature.
11358 Don't warn on intrinsic conversion functions, which start
11359 with two underscores. */
11360 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11361 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11362 gfc_notify_std (GFC_STD_F95_OBS
,
11363 "CHARACTER(*) function %qs at %L",
11364 sym
->name
, &sym
->declared_at
);
11367 /* F2008, C1218. */
11368 if (sym
->attr
.elemental
)
11370 if (sym
->attr
.proc_pointer
)
11372 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11373 sym
->name
, &sym
->declared_at
);
11376 if (sym
->attr
.dummy
)
11378 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11379 sym
->name
, &sym
->declared_at
);
11384 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11386 gfc_formal_arglist
*curr_arg
;
11387 int has_non_interop_arg
= 0;
11389 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11390 sym
->common_block
))
11392 /* Clear these to prevent looking at them again if there was an
11394 sym
->attr
.is_bind_c
= 0;
11395 sym
->attr
.is_c_interop
= 0;
11396 sym
->ts
.is_c_interop
= 0;
11400 /* So far, no errors have been found. */
11401 sym
->attr
.is_c_interop
= 1;
11402 sym
->ts
.is_c_interop
= 1;
11405 curr_arg
= gfc_sym_get_dummy_args (sym
);
11406 while (curr_arg
!= NULL
)
11408 /* Skip implicitly typed dummy args here. */
11409 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11410 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11411 /* If something is found to fail, record the fact so we
11412 can mark the symbol for the procedure as not being
11413 BIND(C) to try and prevent multiple errors being
11415 has_non_interop_arg
= 1;
11417 curr_arg
= curr_arg
->next
;
11420 /* See if any of the arguments were not interoperable and if so, clear
11421 the procedure symbol to prevent duplicate error messages. */
11422 if (has_non_interop_arg
!= 0)
11424 sym
->attr
.is_c_interop
= 0;
11425 sym
->ts
.is_c_interop
= 0;
11426 sym
->attr
.is_bind_c
= 0;
11430 if (!sym
->attr
.proc_pointer
)
11432 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11434 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11435 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11438 if (sym
->attr
.intent
)
11440 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11441 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11444 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11446 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11447 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11450 if (sym
->attr
.external
&& sym
->attr
.function
11451 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11452 || sym
->attr
.contained
))
11454 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11455 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11458 if (strcmp ("ppr@", sym
->name
) == 0)
11460 gfc_error ("Procedure pointer result %qs at %L "
11461 "is missing the pointer attribute",
11462 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11471 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11472 been defined and we now know their defined arguments, check that they fulfill
11473 the requirements of the standard for procedures used as finalizers. */
11476 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11478 gfc_finalizer
* list
;
11479 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11480 bool result
= true;
11481 bool seen_scalar
= false;
11484 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
11487 gfc_resolve_finalizers (parent
, finalizable
);
11489 /* Return early when not finalizable. Additionally, ensure that derived-type
11490 components have a their finalizables resolved. */
11491 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11493 bool has_final
= false;
11494 for (c
= derived
->components
; c
; c
= c
->next
)
11495 if (c
->ts
.type
== BT_DERIVED
11496 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11498 bool has_final2
= false;
11499 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11500 return false; /* Error. */
11501 has_final
= has_final
|| has_final2
;
11506 *finalizable
= false;
11511 /* Walk over the list of finalizer-procedures, check them, and if any one
11512 does not fit in with the standard's definition, print an error and remove
11513 it from the list. */
11514 prev_link
= &derived
->f2k_derived
->finalizers
;
11515 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11517 gfc_formal_arglist
*dummy_args
;
11522 /* Skip this finalizer if we already resolved it. */
11523 if (list
->proc_tree
)
11525 prev_link
= &(list
->next
);
11529 /* Check this exists and is a SUBROUTINE. */
11530 if (!list
->proc_sym
->attr
.subroutine
)
11532 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
11533 list
->proc_sym
->name
, &list
->where
);
11537 /* We should have exactly one argument. */
11538 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11539 if (!dummy_args
|| dummy_args
->next
)
11541 gfc_error ("FINAL procedure at %L must have exactly one argument",
11545 arg
= dummy_args
->sym
;
11547 /* This argument must be of our type. */
11548 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11550 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
11551 &arg
->declared_at
, derived
->name
);
11555 /* It must neither be a pointer nor allocatable nor optional. */
11556 if (arg
->attr
.pointer
)
11558 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11559 &arg
->declared_at
);
11562 if (arg
->attr
.allocatable
)
11564 gfc_error ("Argument of FINAL procedure at %L must not be"
11565 " ALLOCATABLE", &arg
->declared_at
);
11568 if (arg
->attr
.optional
)
11570 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11571 &arg
->declared_at
);
11575 /* It must not be INTENT(OUT). */
11576 if (arg
->attr
.intent
== INTENT_OUT
)
11578 gfc_error ("Argument of FINAL procedure at %L must not be"
11579 " INTENT(OUT)", &arg
->declared_at
);
11583 /* Warn if the procedure is non-scalar and not assumed shape. */
11584 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11585 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11586 gfc_warning (OPT_Wsurprising
,
11587 "Non-scalar FINAL procedure at %L should have assumed"
11588 " shape argument", &arg
->declared_at
);
11590 /* Check that it does not match in kind and rank with a FINAL procedure
11591 defined earlier. To really loop over the *earlier* declarations,
11592 we need to walk the tail of the list as new ones were pushed at the
11594 /* TODO: Handle kind parameters once they are implemented. */
11595 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11596 for (i
= list
->next
; i
; i
= i
->next
)
11598 gfc_formal_arglist
*dummy_args
;
11600 /* Argument list might be empty; that is an error signalled earlier,
11601 but we nevertheless continued resolving. */
11602 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11605 gfc_symbol
* i_arg
= dummy_args
->sym
;
11606 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11607 if (i_rank
== my_rank
)
11609 gfc_error ("FINAL procedure %qs declared at %L has the same"
11610 " rank (%d) as %qs",
11611 list
->proc_sym
->name
, &list
->where
, my_rank
,
11612 i
->proc_sym
->name
);
11618 /* Is this the/a scalar finalizer procedure? */
11619 if (!arg
->as
|| arg
->as
->rank
== 0)
11620 seen_scalar
= true;
11622 /* Find the symtree for this procedure. */
11623 gcc_assert (!list
->proc_tree
);
11624 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11626 prev_link
= &list
->next
;
11629 /* Remove wrong nodes immediately from the list so we don't risk any
11630 troubles in the future when they might fail later expectations. */
11633 *prev_link
= list
->next
;
11634 gfc_free_finalizer (i
);
11638 if (result
== false)
11641 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11642 were nodes in the list, must have been for arrays. It is surely a good
11643 idea to have a scalar version there if there's something to finalize. */
11644 if (warn_surprising
&& result
&& !seen_scalar
)
11645 gfc_warning (OPT_Wsurprising
,
11646 "Only array FINAL procedures declared for derived type %qs"
11647 " defined at %L, suggest also scalar one",
11648 derived
->name
, &derived
->declared_at
);
11650 vtab
= gfc_find_derived_vtab (derived
);
11651 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11652 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11655 *finalizable
= true;
11661 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11664 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11665 const char* generic_name
, locus where
)
11667 gfc_symbol
*sym1
, *sym2
;
11668 const char *pass1
, *pass2
;
11669 gfc_formal_arglist
*dummy_args
;
11671 gcc_assert (t1
->specific
&& t2
->specific
);
11672 gcc_assert (!t1
->specific
->is_generic
);
11673 gcc_assert (!t2
->specific
->is_generic
);
11674 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11676 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11677 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11682 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11683 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11684 || sym1
->attr
.function
!= sym2
->attr
.function
)
11686 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
11687 " GENERIC %qs at %L",
11688 sym1
->name
, sym2
->name
, generic_name
, &where
);
11692 /* Determine PASS arguments. */
11693 if (t1
->specific
->nopass
)
11695 else if (t1
->specific
->pass_arg
)
11696 pass1
= t1
->specific
->pass_arg
;
11699 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
11701 pass1
= dummy_args
->sym
->name
;
11705 if (t2
->specific
->nopass
)
11707 else if (t2
->specific
->pass_arg
)
11708 pass2
= t2
->specific
->pass_arg
;
11711 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
11713 pass2
= dummy_args
->sym
->name
;
11718 /* Compare the interfaces. */
11719 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11720 NULL
, 0, pass1
, pass2
))
11722 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
11723 sym1
->name
, sym2
->name
, generic_name
, &where
);
11731 /* Worker function for resolving a generic procedure binding; this is used to
11732 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11734 The difference between those cases is finding possible inherited bindings
11735 that are overridden, as one has to look for them in tb_sym_root,
11736 tb_uop_root or tb_op, respectively. Thus the caller must already find
11737 the super-type and set p->overridden correctly. */
11740 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11741 gfc_typebound_proc
* p
, const char* name
)
11743 gfc_tbp_generic
* target
;
11744 gfc_symtree
* first_target
;
11745 gfc_symtree
* inherited
;
11747 gcc_assert (p
&& p
->is_generic
);
11749 /* Try to find the specific bindings for the symtrees in our target-list. */
11750 gcc_assert (p
->u
.generic
);
11751 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11752 if (!target
->specific
)
11754 gfc_typebound_proc
* overridden_tbp
;
11755 gfc_tbp_generic
* g
;
11756 const char* target_name
;
11758 target_name
= target
->specific_st
->name
;
11760 /* Defined for this type directly. */
11761 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11763 target
->specific
= target
->specific_st
->n
.tb
;
11764 goto specific_found
;
11767 /* Look for an inherited specific binding. */
11770 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11775 gcc_assert (inherited
->n
.tb
);
11776 target
->specific
= inherited
->n
.tb
;
11777 goto specific_found
;
11781 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
11782 " at %L", target_name
, name
, &p
->where
);
11785 /* Once we've found the specific binding, check it is not ambiguous with
11786 other specifics already found or inherited for the same GENERIC. */
11788 gcc_assert (target
->specific
);
11790 /* This must really be a specific binding! */
11791 if (target
->specific
->is_generic
)
11793 gfc_error ("GENERIC %qs at %L must target a specific binding,"
11794 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
11798 /* Check those already resolved on this type directly. */
11799 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11800 if (g
!= target
&& g
->specific
11801 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11804 /* Check for ambiguity with inherited specific targets. */
11805 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11806 overridden_tbp
= overridden_tbp
->overridden
)
11807 if (overridden_tbp
->is_generic
)
11809 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11811 gcc_assert (g
->specific
);
11812 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11818 /* If we attempt to "overwrite" a specific binding, this is an error. */
11819 if (p
->overridden
&& !p
->overridden
->is_generic
)
11821 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
11822 " the same name", name
, &p
->where
);
11826 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11827 all must have the same attributes here. */
11828 first_target
= p
->u
.generic
->specific
->u
.specific
;
11829 gcc_assert (first_target
);
11830 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11831 p
->function
= first_target
->n
.sym
->attr
.function
;
11837 /* Resolve a GENERIC procedure binding for a derived type. */
11840 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11842 gfc_symbol
* super_type
;
11844 /* Find the overridden binding if any. */
11845 st
->n
.tb
->overridden
= NULL
;
11846 super_type
= gfc_get_derived_super_type (derived
);
11849 gfc_symtree
* overridden
;
11850 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11853 if (overridden
&& overridden
->n
.tb
)
11854 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11857 /* Resolve using worker function. */
11858 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11862 /* Retrieve the target-procedure of an operator binding and do some checks in
11863 common for intrinsic and user-defined type-bound operators. */
11866 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11868 gfc_symbol
* target_proc
;
11870 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11871 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11872 gcc_assert (target_proc
);
11874 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11875 if (target
->specific
->nopass
)
11877 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11881 return target_proc
;
11885 /* Resolve a type-bound intrinsic operator. */
11888 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11889 gfc_typebound_proc
* p
)
11891 gfc_symbol
* super_type
;
11892 gfc_tbp_generic
* target
;
11894 /* If there's already an error here, do nothing (but don't fail again). */
11898 /* Operators should always be GENERIC bindings. */
11899 gcc_assert (p
->is_generic
);
11901 /* Look for an overridden binding. */
11902 super_type
= gfc_get_derived_super_type (derived
);
11903 if (super_type
&& super_type
->f2k_derived
)
11904 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11907 p
->overridden
= NULL
;
11909 /* Resolve general GENERIC properties using worker function. */
11910 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11913 /* Check the targets to be procedures of correct interface. */
11914 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11916 gfc_symbol
* target_proc
;
11918 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11922 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11925 /* Add target to non-typebound operator list. */
11926 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11927 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11929 gfc_interface
*head
, *intr
;
11930 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11932 head
= derived
->ns
->op
[op
];
11933 intr
= gfc_get_interface ();
11934 intr
->sym
= target_proc
;
11935 intr
->where
= p
->where
;
11937 derived
->ns
->op
[op
] = intr
;
11949 /* Resolve a type-bound user operator (tree-walker callback). */
11951 static gfc_symbol
* resolve_bindings_derived
;
11952 static bool resolve_bindings_result
;
11954 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11957 resolve_typebound_user_op (gfc_symtree
* stree
)
11959 gfc_symbol
* super_type
;
11960 gfc_tbp_generic
* target
;
11962 gcc_assert (stree
&& stree
->n
.tb
);
11964 if (stree
->n
.tb
->error
)
11967 /* Operators should always be GENERIC bindings. */
11968 gcc_assert (stree
->n
.tb
->is_generic
);
11970 /* Find overridden procedure, if any. */
11971 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11972 if (super_type
&& super_type
->f2k_derived
)
11974 gfc_symtree
* overridden
;
11975 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11976 stree
->name
, true, NULL
);
11978 if (overridden
&& overridden
->n
.tb
)
11979 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11982 stree
->n
.tb
->overridden
= NULL
;
11984 /* Resolve basically using worker function. */
11985 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11988 /* Check the targets to be functions of correct interface. */
11989 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11991 gfc_symbol
* target_proc
;
11993 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11997 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12004 resolve_bindings_result
= false;
12005 stree
->n
.tb
->error
= 1;
12009 /* Resolve the type-bound procedures for a derived type. */
12012 resolve_typebound_procedure (gfc_symtree
* stree
)
12016 gfc_symbol
* me_arg
;
12017 gfc_symbol
* super_type
;
12018 gfc_component
* comp
;
12020 gcc_assert (stree
);
12022 /* Undefined specific symbol from GENERIC target definition. */
12026 if (stree
->n
.tb
->error
)
12029 /* If this is a GENERIC binding, use that routine. */
12030 if (stree
->n
.tb
->is_generic
)
12032 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12037 /* Get the target-procedure to check it. */
12038 gcc_assert (!stree
->n
.tb
->is_generic
);
12039 gcc_assert (stree
->n
.tb
->u
.specific
);
12040 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12041 where
= stree
->n
.tb
->where
;
12043 /* Default access should already be resolved from the parser. */
12044 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12046 if (stree
->n
.tb
->deferred
)
12048 if (!check_proc_interface (proc
, &where
))
12053 /* Check for F08:C465. */
12054 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12055 || (proc
->attr
.proc
!= PROC_MODULE
12056 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12057 || proc
->attr
.abstract
)
12059 gfc_error ("%qs must be a module procedure or an external procedure with"
12060 " an explicit interface at %L", proc
->name
, &where
);
12065 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12066 stree
->n
.tb
->function
= proc
->attr
.function
;
12068 /* Find the super-type of the current derived type. We could do this once and
12069 store in a global if speed is needed, but as long as not I believe this is
12070 more readable and clearer. */
12071 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12073 /* If PASS, resolve and check arguments if not already resolved / loaded
12074 from a .mod file. */
12075 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12077 gfc_formal_arglist
*dummy_args
;
12079 dummy_args
= gfc_sym_get_dummy_args (proc
);
12080 if (stree
->n
.tb
->pass_arg
)
12082 gfc_formal_arglist
*i
;
12084 /* If an explicit passing argument name is given, walk the arg-list
12085 and look for it. */
12088 stree
->n
.tb
->pass_arg_num
= 1;
12089 for (i
= dummy_args
; i
; i
= i
->next
)
12091 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12096 ++stree
->n
.tb
->pass_arg_num
;
12101 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12103 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12104 stree
->n
.tb
->pass_arg
);
12110 /* Otherwise, take the first one; there should in fact be at least
12112 stree
->n
.tb
->pass_arg_num
= 1;
12115 gfc_error ("Procedure %qs with PASS at %L must have at"
12116 " least one argument", proc
->name
, &where
);
12119 me_arg
= dummy_args
->sym
;
12122 /* Now check that the argument-type matches and the passed-object
12123 dummy argument is generally fine. */
12125 gcc_assert (me_arg
);
12127 if (me_arg
->ts
.type
!= BT_CLASS
)
12129 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12130 " at %L", proc
->name
, &where
);
12134 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12135 != resolve_bindings_derived
)
12137 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12138 " the derived-type %qs", me_arg
->name
, proc
->name
,
12139 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12143 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12144 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12146 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12147 " scalar", proc
->name
, &where
);
12150 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12152 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12153 " be ALLOCATABLE", proc
->name
, &where
);
12156 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12158 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12159 " be POINTER", proc
->name
, &where
);
12164 /* If we are extending some type, check that we don't override a procedure
12165 flagged NON_OVERRIDABLE. */
12166 stree
->n
.tb
->overridden
= NULL
;
12169 gfc_symtree
* overridden
;
12170 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12171 stree
->name
, true, NULL
);
12175 if (overridden
->n
.tb
)
12176 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12178 if (!gfc_check_typebound_override (stree
, overridden
))
12183 /* See if there's a name collision with a component directly in this type. */
12184 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12185 if (!strcmp (comp
->name
, stree
->name
))
12187 gfc_error ("Procedure %qs at %L has the same name as a component of"
12189 stree
->name
, &where
, resolve_bindings_derived
->name
);
12193 /* Try to find a name collision with an inherited component. */
12194 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12196 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12197 " component of %qs",
12198 stree
->name
, &where
, resolve_bindings_derived
->name
);
12202 stree
->n
.tb
->error
= 0;
12206 resolve_bindings_result
= false;
12207 stree
->n
.tb
->error
= 1;
12212 resolve_typebound_procedures (gfc_symbol
* derived
)
12215 gfc_symbol
* super_type
;
12217 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12220 super_type
= gfc_get_derived_super_type (derived
);
12222 resolve_symbol (super_type
);
12224 resolve_bindings_derived
= derived
;
12225 resolve_bindings_result
= true;
12227 if (derived
->f2k_derived
->tb_sym_root
)
12228 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12229 &resolve_typebound_procedure
);
12231 if (derived
->f2k_derived
->tb_uop_root
)
12232 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12233 &resolve_typebound_user_op
);
12235 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12237 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12238 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12239 (gfc_intrinsic_op
)op
, p
))
12240 resolve_bindings_result
= false;
12243 return resolve_bindings_result
;
12247 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12248 to give all identical derived types the same backend_decl. */
12250 add_dt_to_dt_list (gfc_symbol
*derived
)
12252 gfc_dt_list
*dt_list
;
12254 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12255 if (derived
== dt_list
->derived
)
12258 dt_list
= gfc_get_dt_list ();
12259 dt_list
->next
= gfc_derived_types
;
12260 dt_list
->derived
= derived
;
12261 gfc_derived_types
= dt_list
;
12265 /* Ensure that a derived-type is really not abstract, meaning that every
12266 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12269 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12274 if (!ensure_not_abstract_walker (sub
, st
->left
))
12276 if (!ensure_not_abstract_walker (sub
, st
->right
))
12279 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12281 gfc_symtree
* overriding
;
12282 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12285 gcc_assert (overriding
->n
.tb
);
12286 if (overriding
->n
.tb
->deferred
)
12288 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12289 " %qs is DEFERRED and not overridden",
12290 sub
->name
, &sub
->declared_at
, st
->name
);
12299 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12301 /* The algorithm used here is to recursively travel up the ancestry of sub
12302 and for each ancestor-type, check all bindings. If any of them is
12303 DEFERRED, look it up starting from sub and see if the found (overriding)
12304 binding is not DEFERRED.
12305 This is not the most efficient way to do this, but it should be ok and is
12306 clearer than something sophisticated. */
12308 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12310 if (!ancestor
->attr
.abstract
)
12313 /* Walk bindings of this ancestor. */
12314 if (ancestor
->f2k_derived
)
12317 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12322 /* Find next ancestor type and recurse on it. */
12323 ancestor
= gfc_get_derived_super_type (ancestor
);
12325 return ensure_not_abstract (sub
, ancestor
);
12331 /* This check for typebound defined assignments is done recursively
12332 since the order in which derived types are resolved is not always in
12333 order of the declarations. */
12336 check_defined_assignments (gfc_symbol
*derived
)
12340 for (c
= derived
->components
; c
; c
= c
->next
)
12342 if (c
->ts
.type
!= BT_DERIVED
12344 || c
->attr
.allocatable
12345 || c
->attr
.proc_pointer_comp
12346 || c
->attr
.class_pointer
12347 || c
->attr
.proc_pointer
)
12350 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12351 || (c
->ts
.u
.derived
->f2k_derived
12352 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12354 derived
->attr
.defined_assign_comp
= 1;
12358 check_defined_assignments (c
->ts
.u
.derived
);
12359 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12361 derived
->attr
.defined_assign_comp
= 1;
12368 /* Resolve the components of a derived type. This does not have to wait until
12369 resolution stage, but can be done as soon as the dt declaration has been
12373 resolve_fl_derived0 (gfc_symbol
*sym
)
12375 gfc_symbol
* super_type
;
12378 if (sym
->attr
.unlimited_polymorphic
)
12381 super_type
= gfc_get_derived_super_type (sym
);
12384 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12386 gfc_error ("As extending type %qs at %L has a coarray component, "
12387 "parent type %qs shall also have one", sym
->name
,
12388 &sym
->declared_at
, super_type
->name
);
12392 /* Ensure the extended type gets resolved before we do. */
12393 if (super_type
&& !resolve_fl_derived0 (super_type
))
12396 /* An ABSTRACT type must be extensible. */
12397 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12399 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
12400 sym
->name
, &sym
->declared_at
);
12404 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12407 for ( ; c
!= NULL
; c
= c
->next
)
12409 if (c
->attr
.artificial
)
12413 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12414 && c
->attr
.codimension
12415 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12417 gfc_error ("Coarray component %qs at %L must be allocatable with "
12418 "deferred shape", c
->name
, &c
->loc
);
12423 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12424 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12426 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12427 "shall not be a coarray", c
->name
, &c
->loc
);
12432 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12433 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12434 || c
->attr
.allocatable
))
12436 gfc_error ("Component %qs at %L with coarray component "
12437 "shall be a nonpointer, nonallocatable scalar",
12443 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12445 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12446 "is not an array pointer", c
->name
, &c
->loc
);
12450 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12452 gfc_symbol
*ifc
= c
->ts
.interface
;
12454 if (!sym
->attr
.vtype
12455 && !check_proc_interface (ifc
, &c
->loc
))
12458 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12460 /* Resolve interface and copy attributes. */
12461 if (ifc
->formal
&& !ifc
->formal_ns
)
12462 resolve_symbol (ifc
);
12463 if (ifc
->attr
.intrinsic
)
12464 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12468 c
->ts
= ifc
->result
->ts
;
12469 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12470 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12471 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12472 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12473 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12478 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12479 c
->attr
.pointer
= ifc
->attr
.pointer
;
12480 c
->attr
.dimension
= ifc
->attr
.dimension
;
12481 c
->as
= gfc_copy_array_spec (ifc
->as
);
12482 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12484 c
->ts
.interface
= ifc
;
12485 c
->attr
.function
= ifc
->attr
.function
;
12486 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12488 c
->attr
.pure
= ifc
->attr
.pure
;
12489 c
->attr
.elemental
= ifc
->attr
.elemental
;
12490 c
->attr
.recursive
= ifc
->attr
.recursive
;
12491 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12492 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12493 /* Copy char length. */
12494 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12496 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12497 if (cl
->length
&& !cl
->resolved
12498 && !gfc_resolve_expr (cl
->length
))
12504 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12506 /* Since PPCs are not implicitly typed, a PPC without an explicit
12507 interface must be a subroutine. */
12508 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12511 /* Procedure pointer components: Check PASS arg. */
12512 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12513 && !sym
->attr
.vtype
)
12515 gfc_symbol
* me_arg
;
12517 if (c
->tb
->pass_arg
)
12519 gfc_formal_arglist
* i
;
12521 /* If an explicit passing argument name is given, walk the arg-list
12522 and look for it. */
12525 c
->tb
->pass_arg_num
= 1;
12526 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12528 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12533 c
->tb
->pass_arg_num
++;
12538 gfc_error ("Procedure pointer component %qs with PASS(%s) "
12539 "at %L has no argument %qs", c
->name
,
12540 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12547 /* Otherwise, take the first one; there should in fact be at least
12549 c
->tb
->pass_arg_num
= 1;
12550 if (!c
->ts
.interface
->formal
)
12552 gfc_error ("Procedure pointer component %qs with PASS at %L "
12553 "must have at least one argument",
12558 me_arg
= c
->ts
.interface
->formal
->sym
;
12561 /* Now check that the argument-type matches. */
12562 gcc_assert (me_arg
);
12563 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12564 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12565 || (me_arg
->ts
.type
== BT_CLASS
12566 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12568 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12569 " the derived type %qs", me_arg
->name
, c
->name
,
12570 me_arg
->name
, &c
->loc
, sym
->name
);
12575 /* Check for C453. */
12576 if (me_arg
->attr
.dimension
)
12578 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12579 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12585 if (me_arg
->attr
.pointer
)
12587 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12588 "may not have the POINTER attribute", me_arg
->name
,
12589 c
->name
, me_arg
->name
, &c
->loc
);
12594 if (me_arg
->attr
.allocatable
)
12596 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12597 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12598 me_arg
->name
, &c
->loc
);
12603 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12604 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12605 " at %L", c
->name
, &c
->loc
);
12609 /* Check type-spec if this is not the parent-type component. */
12610 if (((sym
->attr
.is_class
12611 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12612 || c
!= sym
->components
->ts
.u
.derived
->components
))
12613 || (!sym
->attr
.is_class
12614 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12615 && !sym
->attr
.vtype
12616 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12619 /* If this type is an extension, set the accessibility of the parent
12622 && ((sym
->attr
.is_class
12623 && c
== sym
->components
->ts
.u
.derived
->components
)
12624 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12625 && strcmp (super_type
->name
, c
->name
) == 0)
12626 c
->attr
.access
= super_type
->attr
.access
;
12628 /* If this type is an extension, see if this component has the same name
12629 as an inherited type-bound procedure. */
12630 if (super_type
&& !sym
->attr
.is_class
12631 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12633 gfc_error ("Component %qs of %qs at %L has the same name as an"
12634 " inherited type-bound procedure",
12635 c
->name
, sym
->name
, &c
->loc
);
12639 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12640 && !c
->ts
.deferred
)
12642 if (c
->ts
.u
.cl
->length
== NULL
12643 || (!resolve_charlen(c
->ts
.u
.cl
))
12644 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12646 gfc_error ("Character length of component %qs needs to "
12647 "be a constant specification expression at %L",
12649 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12654 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12655 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12657 gfc_error ("Character component %qs of %qs at %L with deferred "
12658 "length must be a POINTER or ALLOCATABLE",
12659 c
->name
, sym
->name
, &c
->loc
);
12663 /* Add the hidden deferred length field. */
12664 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
12665 && !sym
->attr
.is_class
)
12667 char name
[GFC_MAX_SYMBOL_LEN
+9];
12668 gfc_component
*strlen
;
12669 sprintf (name
, "_%s_length", c
->name
);
12670 strlen
= gfc_find_component (sym
, name
, true, true);
12671 if (strlen
== NULL
)
12673 if (!gfc_add_component (sym
, name
, &strlen
))
12675 strlen
->ts
.type
= BT_INTEGER
;
12676 strlen
->ts
.kind
= gfc_charlen_int_kind
;
12677 strlen
->attr
.access
= ACCESS_PRIVATE
;
12678 strlen
->attr
.deferred_parameter
= 1;
12682 if (c
->ts
.type
== BT_DERIVED
12683 && sym
->component_access
!= ACCESS_PRIVATE
12684 && gfc_check_symbol_access (sym
)
12685 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12686 && !c
->ts
.u
.derived
->attr
.use_assoc
12687 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12688 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
12689 "PRIVATE type and cannot be a component of "
12690 "%qs, which is PUBLIC at %L", c
->name
,
12691 sym
->name
, &sym
->declared_at
))
12694 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12696 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12697 "type %s", c
->name
, &c
->loc
, sym
->name
);
12701 if (sym
->attr
.sequence
)
12703 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12705 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12706 "not have the SEQUENCE attribute",
12707 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12712 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12713 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12714 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12715 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12716 CLASS_DATA (c
)->ts
.u
.derived
12717 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12719 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12720 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12721 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12723 gfc_error ("The pointer component %qs of %qs at %L is a type "
12724 "that has not been declared", c
->name
, sym
->name
,
12729 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12730 && CLASS_DATA (c
)->attr
.class_pointer
12731 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12732 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12733 && !UNLIMITED_POLY (c
))
12735 gfc_error ("The pointer component %qs of %qs at %L is a type "
12736 "that has not been declared", c
->name
, sym
->name
,
12742 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12743 && (!c
->attr
.class_ok
12744 || !(CLASS_DATA (c
)->attr
.class_pointer
12745 || CLASS_DATA (c
)->attr
.allocatable
)))
12747 gfc_error ("Component %qs with CLASS at %L must be allocatable "
12748 "or pointer", c
->name
, &c
->loc
);
12749 /* Prevent a recurrence of the error. */
12750 c
->ts
.type
= BT_UNKNOWN
;
12754 /* Ensure that all the derived type components are put on the
12755 derived type list; even in formal namespaces, where derived type
12756 pointer components might not have been declared. */
12757 if (c
->ts
.type
== BT_DERIVED
12759 && c
->ts
.u
.derived
->components
12761 && sym
!= c
->ts
.u
.derived
)
12762 add_dt_to_dt_list (c
->ts
.u
.derived
);
12764 if (!gfc_resolve_array_spec (c
->as
,
12765 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12766 || c
->attr
.allocatable
)))
12769 if (c
->initializer
&& !sym
->attr
.vtype
12770 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12774 check_defined_assignments (sym
);
12776 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12777 sym
->attr
.defined_assign_comp
12778 = super_type
->attr
.defined_assign_comp
;
12780 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12781 all DEFERRED bindings are overridden. */
12782 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12783 && !sym
->attr
.is_class
12784 && !ensure_not_abstract (sym
, super_type
))
12787 /* Add derived type to the derived type list. */
12788 add_dt_to_dt_list (sym
);
12794 /* The following procedure does the full resolution of a derived type,
12795 including resolution of all type-bound procedures (if present). In contrast
12796 to 'resolve_fl_derived0' this can only be done after the module has been
12797 parsed completely. */
12800 resolve_fl_derived (gfc_symbol
*sym
)
12802 gfc_symbol
*gen_dt
= NULL
;
12804 if (sym
->attr
.unlimited_polymorphic
)
12807 if (!sym
->attr
.is_class
)
12808 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12809 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12810 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12811 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12812 && !gfc_notify_std_1 (GFC_STD_F2003
, "Generic name '%s' of function "
12813 "'%s' at %L being the same name as derived "
12814 "type at %L", sym
->name
,
12815 gen_dt
->generic
->sym
== sym
12816 ? gen_dt
->generic
->next
->sym
->name
12817 : gen_dt
->generic
->sym
->name
,
12818 gen_dt
->generic
->sym
== sym
12819 ? &gen_dt
->generic
->next
->sym
->declared_at
12820 : &gen_dt
->generic
->sym
->declared_at
,
12821 &sym
->declared_at
))
12824 /* Resolve the finalizer procedures. */
12825 if (!gfc_resolve_finalizers (sym
, NULL
))
12828 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12830 /* Fix up incomplete CLASS symbols. */
12831 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12832 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12834 /* Nothing more to do for unlimited polymorphic entities. */
12835 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12837 else if (vptr
->ts
.u
.derived
== NULL
)
12839 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12841 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12845 if (!resolve_fl_derived0 (sym
))
12848 /* Resolve the type-bound procedures. */
12849 if (!resolve_typebound_procedures (sym
))
12857 resolve_fl_namelist (gfc_symbol
*sym
)
12862 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12864 /* Check again, the check in match only works if NAMELIST comes
12866 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12868 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
12869 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12873 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12874 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12875 "with assumed shape in namelist %qs at %L",
12876 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12879 if (is_non_constant_shape_array (nl
->sym
)
12880 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12881 "with nonconstant shape in namelist %qs at %L",
12882 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12885 if (nl
->sym
->ts
.type
== BT_CHARACTER
12886 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12887 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12888 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
12889 "nonconstant character length in "
12890 "namelist %qs at %L", nl
->sym
->name
,
12891 sym
->name
, &sym
->declared_at
))
12894 /* FIXME: Once UDDTIO is implemented, the following can be
12896 if (nl
->sym
->ts
.type
== BT_CLASS
)
12898 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
12899 "polymorphic and requires a defined input/output "
12900 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12904 if (nl
->sym
->ts
.type
== BT_DERIVED
12905 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12906 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12908 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
12909 "namelist %qs at %L with ALLOCATABLE "
12910 "or POINTER components", nl
->sym
->name
,
12911 sym
->name
, &sym
->declared_at
))
12914 /* FIXME: Once UDDTIO is implemented, the following can be
12916 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
12917 "ALLOCATABLE or POINTER components and thus requires "
12918 "a defined input/output procedure", nl
->sym
->name
,
12919 sym
->name
, &sym
->declared_at
);
12924 /* Reject PRIVATE objects in a PUBLIC namelist. */
12925 if (gfc_check_symbol_access (sym
))
12927 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12929 if (!nl
->sym
->attr
.use_assoc
12930 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12931 && !gfc_check_symbol_access (nl
->sym
))
12933 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
12934 "cannot be member of PUBLIC namelist %qs at %L",
12935 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12939 /* Types with private components that came here by USE-association. */
12940 if (nl
->sym
->ts
.type
== BT_DERIVED
12941 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12943 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
12944 "components and cannot be member of namelist %qs at %L",
12945 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12949 /* Types with private components that are defined in the same module. */
12950 if (nl
->sym
->ts
.type
== BT_DERIVED
12951 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12952 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12954 gfc_error ("NAMELIST object %qs has PRIVATE components and "
12955 "cannot be a member of PUBLIC namelist %qs at %L",
12956 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12963 /* 14.1.2 A module or internal procedure represent local entities
12964 of the same type as a namelist member and so are not allowed. */
12965 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12967 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12970 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12971 if ((nl
->sym
== sym
->ns
->proc_name
)
12973 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12978 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12979 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12981 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12982 "attribute in %qs at %L", nlsym
->name
,
12983 &sym
->declared_at
);
12993 resolve_fl_parameter (gfc_symbol
*sym
)
12995 /* A parameter array's shape needs to be constant. */
12996 if (sym
->as
!= NULL
12997 && (sym
->as
->type
== AS_DEFERRED
12998 || is_non_constant_shape_array (sym
)))
13000 gfc_error ("Parameter array %qs at %L cannot be automatic "
13001 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13005 /* Make sure a parameter that has been implicitly typed still
13006 matches the implicit type, since PARAMETER statements can precede
13007 IMPLICIT statements. */
13008 if (sym
->attr
.implicit_type
13009 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13012 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13013 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13017 /* Make sure the types of derived parameters are consistent. This
13018 type checking is deferred until resolution because the type may
13019 refer to a derived type from the host. */
13020 if (sym
->ts
.type
== BT_DERIVED
13021 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13023 gfc_error ("Incompatible derived type in PARAMETER at %L",
13024 &sym
->value
->where
);
13031 /* Do anything necessary to resolve a symbol. Right now, we just
13032 assume that an otherwise unknown symbol is a variable. This sort
13033 of thing commonly happens for symbols in module. */
13036 resolve_symbol (gfc_symbol
*sym
)
13038 int check_constant
, mp_flag
;
13039 gfc_symtree
*symtree
;
13040 gfc_symtree
*this_symtree
;
13043 symbol_attribute class_attr
;
13044 gfc_array_spec
*as
;
13045 bool saved_specification_expr
;
13051 if (sym
->attr
.artificial
)
13054 if (sym
->attr
.unlimited_polymorphic
)
13057 if (sym
->attr
.flavor
== FL_UNKNOWN
13058 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13059 && !sym
->attr
.generic
&& !sym
->attr
.external
13060 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13061 && sym
->ts
.type
== BT_UNKNOWN
))
13064 /* If we find that a flavorless symbol is an interface in one of the
13065 parent namespaces, find its symtree in this namespace, free the
13066 symbol and set the symtree to point to the interface symbol. */
13067 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13069 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13070 if (symtree
&& (symtree
->n
.sym
->generic
||
13071 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13072 && sym
->ns
->construct_entities
)))
13074 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13076 gfc_release_symbol (sym
);
13077 symtree
->n
.sym
->refs
++;
13078 this_symtree
->n
.sym
= symtree
->n
.sym
;
13083 /* Otherwise give it a flavor according to such attributes as
13085 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13086 && sym
->attr
.intrinsic
== 0)
13087 sym
->attr
.flavor
= FL_VARIABLE
;
13088 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13090 sym
->attr
.flavor
= FL_PROCEDURE
;
13091 if (sym
->attr
.dimension
)
13092 sym
->attr
.function
= 1;
13096 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13097 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13099 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13100 && !resolve_procedure_interface (sym
))
13103 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13104 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13106 if (sym
->attr
.external
)
13107 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13108 "at %L", &sym
->declared_at
);
13110 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13111 "at %L", &sym
->declared_at
);
13116 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13119 /* Symbols that are module procedures with results (functions) have
13120 the types and array specification copied for type checking in
13121 procedures that call them, as well as for saving to a module
13122 file. These symbols can't stand the scrutiny that their results
13124 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13126 /* Make sure that the intrinsic is consistent with its internal
13127 representation. This needs to be done before assigning a default
13128 type to avoid spurious warnings. */
13129 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13130 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13133 /* Resolve associate names. */
13135 resolve_assoc_var (sym
, true);
13137 /* Assign default type to symbols that need one and don't have one. */
13138 if (sym
->ts
.type
== BT_UNKNOWN
)
13140 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13142 gfc_set_default_type (sym
, 1, NULL
);
13145 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13146 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13147 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13148 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13150 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13152 /* The specific case of an external procedure should emit an error
13153 in the case that there is no implicit type. */
13155 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13158 /* Result may be in another namespace. */
13159 resolve_symbol (sym
->result
);
13161 if (!sym
->result
->attr
.proc_pointer
)
13163 sym
->ts
= sym
->result
->ts
;
13164 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13165 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13166 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13167 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13168 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13173 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13175 bool saved_specification_expr
= specification_expr
;
13176 specification_expr
= true;
13177 gfc_resolve_array_spec (sym
->result
->as
, false);
13178 specification_expr
= saved_specification_expr
;
13181 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13183 as
= CLASS_DATA (sym
)->as
;
13184 class_attr
= CLASS_DATA (sym
)->attr
;
13185 class_attr
.pointer
= class_attr
.class_pointer
;
13189 class_attr
= sym
->attr
;
13194 if (sym
->attr
.contiguous
13195 && (!class_attr
.dimension
13196 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13197 && !class_attr
.pointer
)))
13199 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13200 "array pointer or an assumed-shape or assumed-rank array",
13201 sym
->name
, &sym
->declared_at
);
13205 /* Assumed size arrays and assumed shape arrays must be dummy
13206 arguments. Array-spec's of implied-shape should have been resolved to
13207 AS_EXPLICIT already. */
13211 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13212 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13213 || as
->type
== AS_ASSUMED_SHAPE
)
13214 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13216 if (as
->type
== AS_ASSUMED_SIZE
)
13217 gfc_error ("Assumed size array at %L must be a dummy argument",
13218 &sym
->declared_at
);
13220 gfc_error ("Assumed shape array at %L must be a dummy argument",
13221 &sym
->declared_at
);
13224 /* TS 29113, C535a. */
13225 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13226 && !sym
->attr
.select_type_temporary
)
13228 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13229 &sym
->declared_at
);
13232 if (as
->type
== AS_ASSUMED_RANK
13233 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13235 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13236 "CODIMENSION attribute", &sym
->declared_at
);
13241 /* Make sure symbols with known intent or optional are really dummy
13242 variable. Because of ENTRY statement, this has to be deferred
13243 until resolution time. */
13245 if (!sym
->attr
.dummy
13246 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13248 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13252 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13254 gfc_error ("%qs at %L cannot have the VALUE attribute because "
13255 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13259 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13261 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13262 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13264 gfc_error ("Character dummy variable %qs at %L with VALUE "
13265 "attribute must have constant length",
13266 sym
->name
, &sym
->declared_at
);
13270 if (sym
->ts
.is_c_interop
13271 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13273 gfc_error ("C interoperable character dummy variable %qs at %L "
13274 "with VALUE attribute must have length one",
13275 sym
->name
, &sym
->declared_at
);
13280 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13281 && sym
->ts
.u
.derived
->attr
.generic
)
13283 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13284 if (!sym
->ts
.u
.derived
)
13286 gfc_error ("The derived type %qs at %L is of type %qs, "
13287 "which has not been defined", sym
->name
,
13288 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13289 sym
->ts
.type
= BT_UNKNOWN
;
13294 /* Use the same constraints as TYPE(*), except for the type check
13295 and that only scalars and assumed-size arrays are permitted. */
13296 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13298 if (!sym
->attr
.dummy
)
13300 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13301 "a dummy argument", sym
->name
, &sym
->declared_at
);
13305 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13306 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13307 && sym
->ts
.type
!= BT_COMPLEX
)
13309 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13310 "of type TYPE(*) or of an numeric intrinsic type",
13311 sym
->name
, &sym
->declared_at
);
13315 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13316 || sym
->attr
.pointer
|| sym
->attr
.value
)
13318 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13319 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13320 "attribute", sym
->name
, &sym
->declared_at
);
13324 if (sym
->attr
.intent
== INTENT_OUT
)
13326 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13327 "have the INTENT(OUT) attribute",
13328 sym
->name
, &sym
->declared_at
);
13331 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13333 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13334 "either be a scalar or an assumed-size array",
13335 sym
->name
, &sym
->declared_at
);
13339 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13340 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13342 sym
->ts
.type
= BT_ASSUMED
;
13343 sym
->as
= gfc_get_array_spec ();
13344 sym
->as
->type
= AS_ASSUMED_SIZE
;
13346 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13348 else if (sym
->ts
.type
== BT_ASSUMED
)
13350 /* TS 29113, C407a. */
13351 if (!sym
->attr
.dummy
)
13353 gfc_error ("Assumed type of variable %s at %L is only permitted "
13354 "for dummy variables", sym
->name
, &sym
->declared_at
);
13357 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13358 || sym
->attr
.pointer
|| sym
->attr
.value
)
13360 gfc_error ("Assumed-type variable %s at %L may not have the "
13361 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13362 sym
->name
, &sym
->declared_at
);
13365 if (sym
->attr
.intent
== INTENT_OUT
)
13367 gfc_error ("Assumed-type variable %s at %L may not have the "
13368 "INTENT(OUT) attribute",
13369 sym
->name
, &sym
->declared_at
);
13372 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13374 gfc_error ("Assumed-type variable %s at %L shall not be an "
13375 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13380 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13381 do this for something that was implicitly typed because that is handled
13382 in gfc_set_default_type. Handle dummy arguments and procedure
13383 definitions separately. Also, anything that is use associated is not
13384 handled here but instead is handled in the module it is declared in.
13385 Finally, derived type definitions are allowed to be BIND(C) since that
13386 only implies that they're interoperable, and they are checked fully for
13387 interoperability when a variable is declared of that type. */
13388 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13389 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13390 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13394 /* First, make sure the variable is declared at the
13395 module-level scope (J3/04-007, Section 15.3). */
13396 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13397 sym
->attr
.in_common
== 0)
13399 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13400 "is neither a COMMON block nor declared at the "
13401 "module level scope", sym
->name
, &(sym
->declared_at
));
13404 else if (sym
->common_head
!= NULL
)
13406 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13410 /* If type() declaration, we need to verify that the components
13411 of the given type are all C interoperable, etc. */
13412 if (sym
->ts
.type
== BT_DERIVED
&&
13413 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13415 /* Make sure the user marked the derived type as BIND(C). If
13416 not, call the verify routine. This could print an error
13417 for the derived type more than once if multiple variables
13418 of that type are declared. */
13419 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13420 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13424 /* Verify the variable itself as C interoperable if it
13425 is BIND(C). It is not possible for this to succeed if
13426 the verify_bind_c_derived_type failed, so don't have to handle
13427 any error returned by verify_bind_c_derived_type. */
13428 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13429 sym
->common_block
);
13434 /* clear the is_bind_c flag to prevent reporting errors more than
13435 once if something failed. */
13436 sym
->attr
.is_bind_c
= 0;
13441 /* If a derived type symbol has reached this point, without its
13442 type being declared, we have an error. Notice that most
13443 conditions that produce undefined derived types have already
13444 been dealt with. However, the likes of:
13445 implicit type(t) (t) ..... call foo (t) will get us here if
13446 the type is not declared in the scope of the implicit
13447 statement. Change the type to BT_UNKNOWN, both because it is so
13448 and to prevent an ICE. */
13449 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13450 && sym
->ts
.u
.derived
->components
== NULL
13451 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13453 gfc_error ("The derived type %qs at %L is of type %qs, "
13454 "which has not been defined", sym
->name
,
13455 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13456 sym
->ts
.type
= BT_UNKNOWN
;
13460 /* Make sure that the derived type has been resolved and that the
13461 derived type is visible in the symbol's namespace, if it is a
13462 module function and is not PRIVATE. */
13463 if (sym
->ts
.type
== BT_DERIVED
13464 && sym
->ts
.u
.derived
->attr
.use_assoc
13465 && sym
->ns
->proc_name
13466 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13467 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13470 /* Unless the derived-type declaration is use associated, Fortran 95
13471 does not allow public entries of private derived types.
13472 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13473 161 in 95-006r3. */
13474 if (sym
->ts
.type
== BT_DERIVED
13475 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13476 && !sym
->ts
.u
.derived
->attr
.use_assoc
13477 && gfc_check_symbol_access (sym
)
13478 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13479 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
13480 "derived type %qs",
13481 (sym
->attr
.flavor
== FL_PARAMETER
)
13482 ? "parameter" : "variable",
13483 sym
->name
, &sym
->declared_at
,
13484 sym
->ts
.u
.derived
->name
))
13487 /* F2008, C1302. */
13488 if (sym
->ts
.type
== BT_DERIVED
13489 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13490 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13491 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13492 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13494 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13495 "type LOCK_TYPE must be a coarray", sym
->name
,
13496 &sym
->declared_at
);
13500 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13501 default initialization is defined (5.1.2.4.4). */
13502 if (sym
->ts
.type
== BT_DERIVED
13504 && sym
->attr
.intent
== INTENT_OUT
13506 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13508 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13510 if (c
->initializer
)
13512 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
13513 "ASSUMED SIZE and so cannot have a default initializer",
13514 sym
->name
, &sym
->declared_at
);
13521 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13522 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13524 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
13525 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13530 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13531 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13532 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13533 || class_attr
.codimension
)
13534 && (sym
->attr
.result
|| sym
->result
== sym
))
13536 gfc_error ("Function result %qs at %L shall not be a coarray or have "
13537 "a coarray component", sym
->name
, &sym
->declared_at
);
13542 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13543 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13545 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13546 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13551 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13552 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13553 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13554 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13555 || class_attr
.allocatable
))
13557 gfc_error ("Variable %qs at %L with coarray component shall be a "
13558 "nonpointer, nonallocatable scalar, which is not a coarray",
13559 sym
->name
, &sym
->declared_at
);
13563 /* F2008, C526. The function-result case was handled above. */
13564 if (class_attr
.codimension
13565 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13566 || sym
->attr
.select_type_temporary
13567 || sym
->ns
->save_all
13568 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13569 || sym
->ns
->proc_name
->attr
.is_main_program
13570 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13572 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
13573 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13577 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13578 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13580 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
13581 "deferred shape", sym
->name
, &sym
->declared_at
);
13584 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13585 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13587 gfc_error ("Allocatable coarray variable %qs at %L must have "
13588 "deferred shape", sym
->name
, &sym
->declared_at
);
13593 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13594 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13595 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13596 || (class_attr
.codimension
&& class_attr
.allocatable
))
13597 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13599 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
13600 "allocatable coarray or have coarray components",
13601 sym
->name
, &sym
->declared_at
);
13605 if (class_attr
.codimension
&& sym
->attr
.dummy
13606 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13608 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
13609 "procedure %qs", sym
->name
, &sym
->declared_at
,
13610 sym
->ns
->proc_name
->name
);
13614 if (sym
->ts
.type
== BT_LOGICAL
13615 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13616 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13617 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13620 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13621 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13623 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13624 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
13625 "%L with non-C_Bool kind in BIND(C) procedure "
13626 "%qs", sym
->name
, &sym
->declared_at
,
13627 sym
->ns
->proc_name
->name
))
13629 else if (!gfc_logical_kinds
[i
].c_bool
13630 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13631 "%qs at %L with non-C_Bool kind in "
13632 "BIND(C) procedure %qs", sym
->name
,
13634 sym
->attr
.function
? sym
->name
13635 : sym
->ns
->proc_name
->name
))
13639 switch (sym
->attr
.flavor
)
13642 if (!resolve_fl_variable (sym
, mp_flag
))
13647 if (!resolve_fl_procedure (sym
, mp_flag
))
13652 if (!resolve_fl_namelist (sym
))
13657 if (!resolve_fl_parameter (sym
))
13665 /* Resolve array specifier. Check as well some constraints
13666 on COMMON blocks. */
13668 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13670 /* Set the formal_arg_flag so that check_conflict will not throw
13671 an error for host associated variables in the specification
13672 expression for an array_valued function. */
13673 if (sym
->attr
.function
&& sym
->as
)
13674 formal_arg_flag
= 1;
13676 saved_specification_expr
= specification_expr
;
13677 specification_expr
= true;
13678 gfc_resolve_array_spec (sym
->as
, check_constant
);
13679 specification_expr
= saved_specification_expr
;
13681 formal_arg_flag
= 0;
13683 /* Resolve formal namespaces. */
13684 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13685 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13686 gfc_resolve (sym
->formal_ns
);
13688 /* Make sure the formal namespace is present. */
13689 if (sym
->formal
&& !sym
->formal_ns
)
13691 gfc_formal_arglist
*formal
= sym
->formal
;
13692 while (formal
&& !formal
->sym
)
13693 formal
= formal
->next
;
13697 sym
->formal_ns
= formal
->sym
->ns
;
13698 if (sym
->ns
!= formal
->sym
->ns
)
13699 sym
->formal_ns
->refs
++;
13703 /* Check threadprivate restrictions. */
13704 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13705 && (!sym
->attr
.in_common
13706 && sym
->module
== NULL
13707 && (sym
->ns
->proc_name
== NULL
13708 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13709 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13711 /* Check omp declare target restrictions. */
13712 if (sym
->attr
.omp_declare_target
13713 && sym
->attr
.flavor
== FL_VARIABLE
13715 && !sym
->ns
->save_all
13716 && (!sym
->attr
.in_common
13717 && sym
->module
== NULL
13718 && (sym
->ns
->proc_name
== NULL
13719 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13720 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
13721 sym
->name
, &sym
->declared_at
);
13723 /* If we have come this far we can apply default-initializers, as
13724 described in 14.7.5, to those variables that have not already
13725 been assigned one. */
13726 if (sym
->ts
.type
== BT_DERIVED
13728 && !sym
->attr
.allocatable
13729 && !sym
->attr
.alloc_comp
)
13731 symbol_attribute
*a
= &sym
->attr
;
13733 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13734 && !a
->in_common
&& !a
->use_assoc
13735 && (a
->referenced
|| a
->result
)
13736 && !(a
->function
&& sym
!= sym
->result
))
13737 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13738 apply_default_init (sym
);
13741 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13742 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13743 && !CLASS_DATA (sym
)->attr
.class_pointer
13744 && !CLASS_DATA (sym
)->attr
.allocatable
)
13745 apply_default_init (sym
);
13747 /* If this symbol has a type-spec, check it. */
13748 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13749 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13750 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13755 /************* Resolve DATA statements *************/
13759 gfc_data_value
*vnode
;
13765 /* Advance the values structure to point to the next value in the data list. */
13768 next_data_value (void)
13770 while (mpz_cmp_ui (values
.left
, 0) == 0)
13773 if (values
.vnode
->next
== NULL
)
13776 values
.vnode
= values
.vnode
->next
;
13777 mpz_set (values
.left
, values
.vnode
->repeat
);
13785 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13791 ar_type mark
= AR_UNKNOWN
;
13793 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13799 if (!gfc_resolve_expr (var
->expr
))
13803 mpz_init_set_si (offset
, 0);
13806 if (e
->expr_type
!= EXPR_VARIABLE
)
13807 gfc_internal_error ("check_data_variable(): Bad expression");
13809 sym
= e
->symtree
->n
.sym
;
13811 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13813 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
13814 sym
->name
, &sym
->declared_at
);
13817 if (e
->ref
== NULL
&& sym
->as
)
13819 gfc_error ("DATA array %qs at %L must be specified in a previous"
13820 " declaration", sym
->name
, where
);
13824 has_pointer
= sym
->attr
.pointer
;
13826 if (gfc_is_coindexed (e
))
13828 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
13833 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13835 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13839 && ref
->type
== REF_ARRAY
13840 && ref
->u
.ar
.type
!= AR_FULL
)
13842 gfc_error ("DATA element %qs at %L is a pointer and so must "
13843 "be a full array", sym
->name
, where
);
13848 if (e
->rank
== 0 || has_pointer
)
13850 mpz_init_set_ui (size
, 1);
13857 /* Find the array section reference. */
13858 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13860 if (ref
->type
!= REF_ARRAY
)
13862 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13868 /* Set marks according to the reference pattern. */
13869 switch (ref
->u
.ar
.type
)
13877 /* Get the start position of array section. */
13878 gfc_get_section_index (ar
, section_index
, &offset
);
13883 gcc_unreachable ();
13886 if (!gfc_array_size (e
, &size
))
13888 gfc_error ("Nonconstant array section at %L in DATA statement",
13890 mpz_clear (offset
);
13897 while (mpz_cmp_ui (size
, 0) > 0)
13899 if (!next_data_value ())
13901 gfc_error ("DATA statement at %L has more variables than values",
13907 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13911 /* If we have more than one element left in the repeat count,
13912 and we have more than one element left in the target variable,
13913 then create a range assignment. */
13914 /* FIXME: Only done for full arrays for now, since array sections
13916 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13917 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13921 if (mpz_cmp (size
, values
.left
) >= 0)
13923 mpz_init_set (range
, values
.left
);
13924 mpz_sub (size
, size
, values
.left
);
13925 mpz_set_ui (values
.left
, 0);
13929 mpz_init_set (range
, size
);
13930 mpz_sub (values
.left
, values
.left
, size
);
13931 mpz_set_ui (size
, 0);
13934 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13937 mpz_add (offset
, offset
, range
);
13944 /* Assign initial value to symbol. */
13947 mpz_sub_ui (values
.left
, values
.left
, 1);
13948 mpz_sub_ui (size
, size
, 1);
13950 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13955 if (mark
== AR_FULL
)
13956 mpz_add_ui (offset
, offset
, 1);
13958 /* Modify the array section indexes and recalculate the offset
13959 for next element. */
13960 else if (mark
== AR_SECTION
)
13961 gfc_advance_section (section_index
, ar
, &offset
);
13965 if (mark
== AR_SECTION
)
13967 for (i
= 0; i
< ar
->dimen
; i
++)
13968 mpz_clear (section_index
[i
]);
13972 mpz_clear (offset
);
13978 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13980 /* Iterate over a list of elements in a DATA statement. */
13983 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13986 iterator_stack frame
;
13987 gfc_expr
*e
, *start
, *end
, *step
;
13988 bool retval
= true;
13990 mpz_init (frame
.value
);
13993 start
= gfc_copy_expr (var
->iter
.start
);
13994 end
= gfc_copy_expr (var
->iter
.end
);
13995 step
= gfc_copy_expr (var
->iter
.step
);
13997 if (!gfc_simplify_expr (start
, 1)
13998 || start
->expr_type
!= EXPR_CONSTANT
)
14000 gfc_error ("start of implied-do loop at %L could not be "
14001 "simplified to a constant value", &start
->where
);
14005 if (!gfc_simplify_expr (end
, 1)
14006 || end
->expr_type
!= EXPR_CONSTANT
)
14008 gfc_error ("end of implied-do loop at %L could not be "
14009 "simplified to a constant value", &start
->where
);
14013 if (!gfc_simplify_expr (step
, 1)
14014 || step
->expr_type
!= EXPR_CONSTANT
)
14016 gfc_error ("step of implied-do loop at %L could not be "
14017 "simplified to a constant value", &start
->where
);
14022 mpz_set (trip
, end
->value
.integer
);
14023 mpz_sub (trip
, trip
, start
->value
.integer
);
14024 mpz_add (trip
, trip
, step
->value
.integer
);
14026 mpz_div (trip
, trip
, step
->value
.integer
);
14028 mpz_set (frame
.value
, start
->value
.integer
);
14030 frame
.prev
= iter_stack
;
14031 frame
.variable
= var
->iter
.var
->symtree
;
14032 iter_stack
= &frame
;
14034 while (mpz_cmp_ui (trip
, 0) > 0)
14036 if (!traverse_data_var (var
->list
, where
))
14042 e
= gfc_copy_expr (var
->expr
);
14043 if (!gfc_simplify_expr (e
, 1))
14050 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14052 mpz_sub_ui (trip
, trip
, 1);
14056 mpz_clear (frame
.value
);
14059 gfc_free_expr (start
);
14060 gfc_free_expr (end
);
14061 gfc_free_expr (step
);
14063 iter_stack
= frame
.prev
;
14068 /* Type resolve variables in the variable list of a DATA statement. */
14071 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14075 for (; var
; var
= var
->next
)
14077 if (var
->expr
== NULL
)
14078 t
= traverse_data_list (var
, where
);
14080 t
= check_data_variable (var
, where
);
14090 /* Resolve the expressions and iterators associated with a data statement.
14091 This is separate from the assignment checking because data lists should
14092 only be resolved once. */
14095 resolve_data_variables (gfc_data_variable
*d
)
14097 for (; d
; d
= d
->next
)
14099 if (d
->list
== NULL
)
14101 if (!gfc_resolve_expr (d
->expr
))
14106 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14109 if (!resolve_data_variables (d
->list
))
14118 /* Resolve a single DATA statement. We implement this by storing a pointer to
14119 the value list into static variables, and then recursively traversing the
14120 variables list, expanding iterators and such. */
14123 resolve_data (gfc_data
*d
)
14126 if (!resolve_data_variables (d
->var
))
14129 values
.vnode
= d
->value
;
14130 if (d
->value
== NULL
)
14131 mpz_set_ui (values
.left
, 0);
14133 mpz_set (values
.left
, d
->value
->repeat
);
14135 if (!traverse_data_var (d
->var
, &d
->where
))
14138 /* At this point, we better not have any values left. */
14140 if (next_data_value ())
14141 gfc_error ("DATA statement at %L has more values than variables",
14146 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14147 accessed by host or use association, is a dummy argument to a pure function,
14148 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14149 is storage associated with any such variable, shall not be used in the
14150 following contexts: (clients of this function). */
14152 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14153 procedure. Returns zero if assignment is OK, nonzero if there is a
14156 gfc_impure_variable (gfc_symbol
*sym
)
14161 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14164 /* Check if the symbol's ns is inside the pure procedure. */
14165 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14169 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14173 proc
= sym
->ns
->proc_name
;
14174 if (sym
->attr
.dummy
14175 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14176 || proc
->attr
.function
))
14179 /* TODO: Sort out what can be storage associated, if anything, and include
14180 it here. In principle equivalences should be scanned but it does not
14181 seem to be possible to storage associate an impure variable this way. */
14186 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14187 current namespace is inside a pure procedure. */
14190 gfc_pure (gfc_symbol
*sym
)
14192 symbol_attribute attr
;
14197 /* Check if the current namespace or one of its parents
14198 belongs to a pure procedure. */
14199 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14201 sym
= ns
->proc_name
;
14205 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14213 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14217 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14218 checks if the current namespace is implicitly pure. Note that this
14219 function returns false for a PURE procedure. */
14222 gfc_implicit_pure (gfc_symbol
*sym
)
14228 /* Check if the current procedure is implicit_pure. Walk up
14229 the procedure list until we find a procedure. */
14230 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14232 sym
= ns
->proc_name
;
14236 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14241 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14242 && !sym
->attr
.pure
;
14247 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14253 /* Check if the current procedure is implicit_pure. Walk up
14254 the procedure list until we find a procedure. */
14255 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14257 sym
= ns
->proc_name
;
14261 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14266 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14267 sym
->attr
.implicit_pure
= 0;
14269 sym
->attr
.pure
= 0;
14273 /* Test whether the current procedure is elemental or not. */
14276 gfc_elemental (gfc_symbol
*sym
)
14278 symbol_attribute attr
;
14281 sym
= gfc_current_ns
->proc_name
;
14286 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14290 /* Warn about unused labels. */
14293 warn_unused_fortran_label (gfc_st_label
*label
)
14298 warn_unused_fortran_label (label
->left
);
14300 if (label
->defined
== ST_LABEL_UNKNOWN
)
14303 switch (label
->referenced
)
14305 case ST_LABEL_UNKNOWN
:
14306 gfc_warning ("Label %d at %L defined but not used", label
->value
,
14310 case ST_LABEL_BAD_TARGET
:
14311 gfc_warning ("Label %d at %L defined but cannot be used",
14312 label
->value
, &label
->where
);
14319 warn_unused_fortran_label (label
->right
);
14323 /* Returns the sequence type of a symbol or sequence. */
14326 sequence_type (gfc_typespec ts
)
14335 if (ts
.u
.derived
->components
== NULL
)
14336 return SEQ_NONDEFAULT
;
14338 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14339 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14340 if (sequence_type (c
->ts
) != result
)
14346 if (ts
.kind
!= gfc_default_character_kind
)
14347 return SEQ_NONDEFAULT
;
14349 return SEQ_CHARACTER
;
14352 if (ts
.kind
!= gfc_default_integer_kind
)
14353 return SEQ_NONDEFAULT
;
14355 return SEQ_NUMERIC
;
14358 if (!(ts
.kind
== gfc_default_real_kind
14359 || ts
.kind
== gfc_default_double_kind
))
14360 return SEQ_NONDEFAULT
;
14362 return SEQ_NUMERIC
;
14365 if (ts
.kind
!= gfc_default_complex_kind
)
14366 return SEQ_NONDEFAULT
;
14368 return SEQ_NUMERIC
;
14371 if (ts
.kind
!= gfc_default_logical_kind
)
14372 return SEQ_NONDEFAULT
;
14374 return SEQ_NUMERIC
;
14377 return SEQ_NONDEFAULT
;
14382 /* Resolve derived type EQUIVALENCE object. */
14385 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14387 gfc_component
*c
= derived
->components
;
14392 /* Shall not be an object of nonsequence derived type. */
14393 if (!derived
->attr
.sequence
)
14395 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
14396 "attribute to be an EQUIVALENCE object", sym
->name
,
14401 /* Shall not have allocatable components. */
14402 if (derived
->attr
.alloc_comp
)
14404 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
14405 "components to be an EQUIVALENCE object",sym
->name
,
14410 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14412 gfc_error ("Derived type variable %qs at %L with default "
14413 "initialization cannot be in EQUIVALENCE with a variable "
14414 "in COMMON", sym
->name
, &e
->where
);
14418 for (; c
; c
= c
->next
)
14420 if (c
->ts
.type
== BT_DERIVED
14421 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14424 /* Shall not be an object of sequence derived type containing a pointer
14425 in the structure. */
14426 if (c
->attr
.pointer
)
14428 gfc_error ("Derived type variable %qs at %L with pointer "
14429 "component(s) cannot be an EQUIVALENCE object",
14430 sym
->name
, &e
->where
);
14438 /* Resolve equivalence object.
14439 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14440 an allocatable array, an object of nonsequence derived type, an object of
14441 sequence derived type containing a pointer at any level of component
14442 selection, an automatic object, a function name, an entry name, a result
14443 name, a named constant, a structure component, or a subobject of any of
14444 the preceding objects. A substring shall not have length zero. A
14445 derived type shall not have components with default initialization nor
14446 shall two objects of an equivalence group be initialized.
14447 Either all or none of the objects shall have an protected attribute.
14448 The simple constraints are done in symbol.c(check_conflict) and the rest
14449 are implemented here. */
14452 resolve_equivalence (gfc_equiv
*eq
)
14455 gfc_symbol
*first_sym
;
14458 locus
*last_where
= NULL
;
14459 seq_type eq_type
, last_eq_type
;
14460 gfc_typespec
*last_ts
;
14461 int object
, cnt_protected
;
14464 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14466 first_sym
= eq
->expr
->symtree
->n
.sym
;
14470 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14474 e
->ts
= e
->symtree
->n
.sym
->ts
;
14475 /* match_varspec might not know yet if it is seeing
14476 array reference or substring reference, as it doesn't
14478 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14480 gfc_ref
*ref
= e
->ref
;
14481 sym
= e
->symtree
->n
.sym
;
14483 if (sym
->attr
.dimension
)
14485 ref
->u
.ar
.as
= sym
->as
;
14489 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14490 if (e
->ts
.type
== BT_CHARACTER
14492 && ref
->type
== REF_ARRAY
14493 && ref
->u
.ar
.dimen
== 1
14494 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14495 && ref
->u
.ar
.stride
[0] == NULL
)
14497 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14498 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14501 /* Optimize away the (:) reference. */
14502 if (start
== NULL
&& end
== NULL
)
14505 e
->ref
= ref
->next
;
14507 e
->ref
->next
= ref
->next
;
14512 ref
->type
= REF_SUBSTRING
;
14514 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14516 ref
->u
.ss
.start
= start
;
14517 if (end
== NULL
&& e
->ts
.u
.cl
)
14518 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14519 ref
->u
.ss
.end
= end
;
14520 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14527 /* Any further ref is an error. */
14530 gcc_assert (ref
->type
== REF_ARRAY
);
14531 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14537 if (!gfc_resolve_expr (e
))
14540 sym
= e
->symtree
->n
.sym
;
14542 if (sym
->attr
.is_protected
)
14544 if (cnt_protected
> 0 && cnt_protected
!= object
)
14546 gfc_error ("Either all or none of the objects in the "
14547 "EQUIVALENCE set at %L shall have the "
14548 "PROTECTED attribute",
14553 /* Shall not equivalence common block variables in a PURE procedure. */
14554 if (sym
->ns
->proc_name
14555 && sym
->ns
->proc_name
->attr
.pure
14556 && sym
->attr
.in_common
)
14558 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
14559 "object in the pure procedure %qs",
14560 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14564 /* Shall not be a named constant. */
14565 if (e
->expr_type
== EXPR_CONSTANT
)
14567 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
14568 "object", sym
->name
, &e
->where
);
14572 if (e
->ts
.type
== BT_DERIVED
14573 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14576 /* Check that the types correspond correctly:
14578 A numeric sequence structure may be equivalenced to another sequence
14579 structure, an object of default integer type, default real type, double
14580 precision real type, default logical type such that components of the
14581 structure ultimately only become associated to objects of the same
14582 kind. A character sequence structure may be equivalenced to an object
14583 of default character kind or another character sequence structure.
14584 Other objects may be equivalenced only to objects of the same type and
14585 kind parameters. */
14587 /* Identical types are unconditionally OK. */
14588 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14589 goto identical_types
;
14591 last_eq_type
= sequence_type (*last_ts
);
14592 eq_type
= sequence_type (sym
->ts
);
14594 /* Since the pair of objects is not of the same type, mixed or
14595 non-default sequences can be rejected. */
14597 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14598 "statement at %L with different type objects";
14600 && last_eq_type
== SEQ_MIXED
14601 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14602 || (eq_type
== SEQ_MIXED
14603 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14606 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14607 "statement at %L with objects of different type";
14609 && last_eq_type
== SEQ_NONDEFAULT
14610 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14611 || (eq_type
== SEQ_NONDEFAULT
14612 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14615 msg
="Non-CHARACTER object %qs in default CHARACTER "
14616 "EQUIVALENCE statement at %L";
14617 if (last_eq_type
== SEQ_CHARACTER
14618 && eq_type
!= SEQ_CHARACTER
14619 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14622 msg
="Non-NUMERIC object %qs in default NUMERIC "
14623 "EQUIVALENCE statement at %L";
14624 if (last_eq_type
== SEQ_NUMERIC
14625 && eq_type
!= SEQ_NUMERIC
14626 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14631 last_where
= &e
->where
;
14636 /* Shall not be an automatic array. */
14637 if (e
->ref
->type
== REF_ARRAY
14638 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14640 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
14641 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14648 /* Shall not be a structure component. */
14649 if (r
->type
== REF_COMPONENT
)
14651 gfc_error ("Structure component %qs at %L cannot be an "
14652 "EQUIVALENCE object",
14653 r
->u
.c
.component
->name
, &e
->where
);
14657 /* A substring shall not have length zero. */
14658 if (r
->type
== REF_SUBSTRING
)
14660 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14662 gfc_error ("Substring at %L has length zero",
14663 &r
->u
.ss
.start
->where
);
14673 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14676 resolve_fntype (gfc_namespace
*ns
)
14678 gfc_entry_list
*el
;
14681 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14684 /* If there are any entries, ns->proc_name is the entry master
14685 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14687 sym
= ns
->entries
->sym
;
14689 sym
= ns
->proc_name
;
14690 if (sym
->result
== sym
14691 && sym
->ts
.type
== BT_UNKNOWN
14692 && !gfc_set_default_type (sym
, 0, NULL
)
14693 && !sym
->attr
.untyped
)
14695 gfc_error ("Function %qs at %L has no IMPLICIT type",
14696 sym
->name
, &sym
->declared_at
);
14697 sym
->attr
.untyped
= 1;
14700 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14701 && !sym
->attr
.contained
14702 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14703 && gfc_check_symbol_access (sym
))
14705 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
14706 "%L of PRIVATE type %qs", sym
->name
,
14707 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14711 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14713 if (el
->sym
->result
== el
->sym
14714 && el
->sym
->ts
.type
== BT_UNKNOWN
14715 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14716 && !el
->sym
->attr
.untyped
)
14718 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
14719 el
->sym
->name
, &el
->sym
->declared_at
);
14720 el
->sym
->attr
.untyped
= 1;
14726 /* 12.3.2.1.1 Defined operators. */
14729 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14731 gfc_formal_arglist
*formal
;
14733 if (!sym
->attr
.function
)
14735 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
14736 sym
->name
, &where
);
14740 if (sym
->ts
.type
== BT_CHARACTER
14741 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14742 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14743 && sym
->result
->ts
.u
.cl
->length
))
14745 gfc_error ("User operator procedure %qs at %L cannot be assumed "
14746 "character length", sym
->name
, &where
);
14750 formal
= gfc_sym_get_dummy_args (sym
);
14751 if (!formal
|| !formal
->sym
)
14753 gfc_error ("User operator procedure %qs at %L must have at least "
14754 "one argument", sym
->name
, &where
);
14758 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14760 gfc_error ("First argument of operator interface at %L must be "
14761 "INTENT(IN)", &where
);
14765 if (formal
->sym
->attr
.optional
)
14767 gfc_error ("First argument of operator interface at %L cannot be "
14768 "optional", &where
);
14772 formal
= formal
->next
;
14773 if (!formal
|| !formal
->sym
)
14776 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14778 gfc_error ("Second argument of operator interface at %L must be "
14779 "INTENT(IN)", &where
);
14783 if (formal
->sym
->attr
.optional
)
14785 gfc_error ("Second argument of operator interface at %L cannot be "
14786 "optional", &where
);
14792 gfc_error ("Operator interface at %L must have, at most, two "
14793 "arguments", &where
);
14801 gfc_resolve_uops (gfc_symtree
*symtree
)
14803 gfc_interface
*itr
;
14805 if (symtree
== NULL
)
14808 gfc_resolve_uops (symtree
->left
);
14809 gfc_resolve_uops (symtree
->right
);
14811 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14812 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14816 /* Examine all of the expressions associated with a program unit,
14817 assign types to all intermediate expressions, make sure that all
14818 assignments are to compatible types and figure out which names
14819 refer to which functions or subroutines. It doesn't check code
14820 block, which is handled by gfc_resolve_code. */
14823 resolve_types (gfc_namespace
*ns
)
14829 gfc_namespace
* old_ns
= gfc_current_ns
;
14831 /* Check that all IMPLICIT types are ok. */
14832 if (!ns
->seen_implicit_none
)
14835 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14836 if (ns
->set_flag
[letter
]
14837 && !resolve_typespec_used (&ns
->default_type
[letter
],
14838 &ns
->implicit_loc
[letter
], NULL
))
14842 gfc_current_ns
= ns
;
14844 resolve_entries (ns
);
14846 resolve_common_vars (ns
->blank_common
.head
, false);
14847 resolve_common_blocks (ns
->common_root
);
14849 resolve_contained_functions (ns
);
14851 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14852 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14853 resolve_formal_arglist (ns
->proc_name
);
14855 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14857 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14858 resolve_charlen (cl
);
14860 gfc_traverse_ns (ns
, resolve_symbol
);
14862 resolve_fntype (ns
);
14864 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14866 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14867 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
14868 "also be PURE", n
->proc_name
->name
,
14869 &n
->proc_name
->declared_at
);
14875 gfc_do_concurrent_flag
= 0;
14876 gfc_check_interfaces (ns
);
14878 gfc_traverse_ns (ns
, resolve_values
);
14884 for (d
= ns
->data
; d
; d
= d
->next
)
14888 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14890 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14892 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14893 resolve_equivalence (eq
);
14895 /* Warn about unused labels. */
14896 if (warn_unused_label
)
14897 warn_unused_fortran_label (ns
->st_labels
);
14899 gfc_resolve_uops (ns
->uop_root
);
14901 gfc_resolve_omp_declare_simd (ns
);
14903 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
14905 gfc_current_ns
= old_ns
;
14909 /* Call gfc_resolve_code recursively. */
14912 resolve_codes (gfc_namespace
*ns
)
14915 bitmap_obstack old_obstack
;
14917 if (ns
->resolved
== 1)
14920 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14923 gfc_current_ns
= ns
;
14925 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14926 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14929 /* Set to an out of range value. */
14930 current_entry_id
= -1;
14932 old_obstack
= labels_obstack
;
14933 bitmap_obstack_initialize (&labels_obstack
);
14935 gfc_resolve_oacc_declare (ns
);
14936 gfc_resolve_code (ns
->code
, ns
);
14938 bitmap_obstack_release (&labels_obstack
);
14939 labels_obstack
= old_obstack
;
14943 /* This function is called after a complete program unit has been compiled.
14944 Its purpose is to examine all of the expressions associated with a program
14945 unit, assign types to all intermediate expressions, make sure that all
14946 assignments are to compatible types and figure out which names refer to
14947 which functions or subroutines. */
14950 gfc_resolve (gfc_namespace
*ns
)
14952 gfc_namespace
*old_ns
;
14953 code_stack
*old_cs_base
;
14959 old_ns
= gfc_current_ns
;
14960 old_cs_base
= cs_base
;
14962 resolve_types (ns
);
14963 component_assignment_level
= 0;
14964 resolve_codes (ns
);
14966 gfc_current_ns
= old_ns
;
14967 cs_base
= old_cs_base
;
14970 gfc_run_passes (ns
);