1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2015 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 (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.intent
== INTENT_OUT
)
421 gfc_error ("INTENT(OUT) argument '%s' of pure procedure %qs at %L"
422 " may not be polymorphic", sym
->name
, proc
->name
,
428 if (proc
->attr
.implicit_pure
)
430 if (sym
->attr
.flavor
== FL_PROCEDURE
)
433 proc
->attr
.implicit_pure
= 0;
435 else if (!sym
->attr
.pointer
)
437 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
439 proc
->attr
.implicit_pure
= 0;
441 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
443 proc
->attr
.implicit_pure
= 0;
447 if (gfc_elemental (proc
))
450 if (sym
->attr
.codimension
451 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
452 && CLASS_DATA (sym
)->attr
.codimension
))
454 gfc_error ("Coarray dummy argument %qs at %L to elemental "
455 "procedure", sym
->name
, &sym
->declared_at
);
459 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->as
))
462 gfc_error ("Argument %qs of elemental procedure at %L must "
463 "be scalar", sym
->name
, &sym
->declared_at
);
467 if (sym
->attr
.allocatable
468 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
469 && CLASS_DATA (sym
)->attr
.allocatable
))
471 gfc_error ("Argument %qs of elemental procedure at %L cannot "
472 "have the ALLOCATABLE attribute", sym
->name
,
477 if (sym
->attr
.pointer
478 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
479 && CLASS_DATA (sym
)->attr
.class_pointer
))
481 gfc_error ("Argument %qs of elemental procedure at %L cannot "
482 "have the POINTER attribute", sym
->name
,
487 if (sym
->attr
.flavor
== FL_PROCEDURE
)
489 gfc_error ("Dummy procedure %qs not allowed in elemental "
490 "procedure %qs at %L", sym
->name
, proc
->name
,
495 /* Fortran 2008 Corrigendum 1, C1290a. */
496 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
498 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
499 "have its INTENT specified or have the VALUE "
500 "attribute", sym
->name
, proc
->name
,
506 /* Each dummy shall be specified to be scalar. */
507 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
511 gfc_error ("Argument %qs of statement function at %L must "
512 "be scalar", sym
->name
, &sym
->declared_at
);
516 if (sym
->ts
.type
== BT_CHARACTER
)
518 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
519 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
521 gfc_error ("Character-valued argument %qs of statement "
522 "function at %L must have constant length",
523 sym
->name
, &sym
->declared_at
);
533 /* Work function called when searching for symbols that have argument lists
534 associated with them. */
537 find_arglists (gfc_symbol
*sym
)
539 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
540 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
543 resolve_formal_arglist (sym
);
547 /* Given a namespace, resolve all formal argument lists within the namespace.
551 resolve_formal_arglists (gfc_namespace
*ns
)
556 gfc_traverse_ns (ns
, find_arglists
);
561 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
565 /* If this namespace is not a function or an entry master function,
567 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
568 || sym
->attr
.entry_master
)
571 /* Try to find out of what the return type is. */
572 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
574 t
= gfc_set_default_type (sym
->result
, 0, ns
);
576 if (!t
&& !sym
->result
->attr
.untyped
)
578 if (sym
->result
== sym
)
579 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
580 sym
->name
, &sym
->declared_at
);
581 else if (!sym
->result
->attr
.proc_pointer
)
582 gfc_error ("Result %qs of contained function %qs at %L has "
583 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
584 &sym
->result
->declared_at
);
585 sym
->result
->attr
.untyped
= 1;
589 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
590 type, lists the only ways a character length value of * can be used:
591 dummy arguments of procedures, named constants, and function results
592 in external functions. Internal function results and results of module
593 procedures are not on this list, ergo, not permitted. */
595 if (sym
->result
->ts
.type
== BT_CHARACTER
)
597 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
598 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
600 /* See if this is a module-procedure and adapt error message
603 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
604 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
606 gfc_error ("Character-valued %s %qs at %L must not be"
608 module_proc
? _("module procedure")
609 : _("internal function"),
610 sym
->name
, &sym
->declared_at
);
616 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
617 introduce duplicates. */
620 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
622 gfc_formal_arglist
*f
, *new_arglist
;
625 for (; new_args
!= NULL
; new_args
= new_args
->next
)
627 new_sym
= new_args
->sym
;
628 /* See if this arg is already in the formal argument list. */
629 for (f
= proc
->formal
; f
; f
= f
->next
)
631 if (new_sym
== f
->sym
)
638 /* Add a new argument. Argument order is not important. */
639 new_arglist
= gfc_get_formal_arglist ();
640 new_arglist
->sym
= new_sym
;
641 new_arglist
->next
= proc
->formal
;
642 proc
->formal
= new_arglist
;
647 /* Flag the arguments that are not present in all entries. */
650 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
652 gfc_formal_arglist
*f
, *head
;
655 for (f
= proc
->formal
; f
; f
= f
->next
)
660 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
662 if (new_args
->sym
== f
->sym
)
669 f
->sym
->attr
.not_always_present
= 1;
674 /* Resolve alternate entry points. If a symbol has multiple entry points we
675 create a new master symbol for the main routine, and turn the existing
676 symbol into an entry point. */
679 resolve_entries (gfc_namespace
*ns
)
681 gfc_namespace
*old_ns
;
685 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
686 static int master_count
= 0;
688 if (ns
->proc_name
== NULL
)
691 /* No need to do anything if this procedure doesn't have alternate entry
696 /* We may already have resolved alternate entry points. */
697 if (ns
->proc_name
->attr
.entry_master
)
700 /* If this isn't a procedure something has gone horribly wrong. */
701 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
703 /* Remember the current namespace. */
704 old_ns
= gfc_current_ns
;
708 /* Add the main entry point to the list of entry points. */
709 el
= gfc_get_entry_list ();
710 el
->sym
= ns
->proc_name
;
712 el
->next
= ns
->entries
;
714 ns
->proc_name
->attr
.entry
= 1;
716 /* If it is a module function, it needs to be in the right namespace
717 so that gfc_get_fake_result_decl can gather up the results. The
718 need for this arose in get_proc_name, where these beasts were
719 left in their own namespace, to keep prior references linked to
720 the entry declaration.*/
721 if (ns
->proc_name
->attr
.function
722 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
725 /* Do the same for entries where the master is not a module
726 procedure. These are retained in the module namespace because
727 of the module procedure declaration. */
728 for (el
= el
->next
; el
; el
= el
->next
)
729 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
730 && el
->sym
->attr
.mod_proc
)
734 /* Add an entry statement for it. */
735 c
= gfc_get_code (EXEC_ENTRY
);
740 /* Create a new symbol for the master function. */
741 /* Give the internal function a unique name (within this file).
742 Also include the function name so the user has some hope of figuring
743 out what is going on. */
744 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
745 master_count
++, ns
->proc_name
->name
);
746 gfc_get_ha_symbol (name
, &proc
);
747 gcc_assert (proc
!= NULL
);
749 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
750 if (ns
->proc_name
->attr
.subroutine
)
751 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
755 gfc_typespec
*ts
, *fts
;
756 gfc_array_spec
*as
, *fas
;
757 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
759 fas
= ns
->entries
->sym
->as
;
760 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
761 fts
= &ns
->entries
->sym
->result
->ts
;
762 if (fts
->type
== BT_UNKNOWN
)
763 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
764 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
766 ts
= &el
->sym
->result
->ts
;
768 as
= as
? as
: el
->sym
->result
->as
;
769 if (ts
->type
== BT_UNKNOWN
)
770 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
772 if (! gfc_compare_types (ts
, fts
)
773 || (el
->sym
->result
->attr
.dimension
774 != ns
->entries
->sym
->result
->attr
.dimension
)
775 || (el
->sym
->result
->attr
.pointer
776 != ns
->entries
->sym
->result
->attr
.pointer
))
778 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
779 && gfc_compare_array_spec (as
, fas
) == 0)
780 gfc_error ("Function %s at %L has entries with mismatched "
781 "array specifications", ns
->entries
->sym
->name
,
782 &ns
->entries
->sym
->declared_at
);
783 /* The characteristics need to match and thus both need to have
784 the same string length, i.e. both len=*, or both len=4.
785 Having both len=<variable> is also possible, but difficult to
786 check at compile time. */
787 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
788 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
789 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
791 && ts
->u
.cl
->length
->expr_type
792 != fts
->u
.cl
->length
->expr_type
)
794 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
795 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
796 fts
->u
.cl
->length
->value
.integer
) != 0)))
797 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
798 "entries returning variables of different "
799 "string lengths", ns
->entries
->sym
->name
,
800 &ns
->entries
->sym
->declared_at
);
805 sym
= ns
->entries
->sym
->result
;
806 /* All result types the same. */
808 if (sym
->attr
.dimension
)
809 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
810 if (sym
->attr
.pointer
)
811 gfc_add_pointer (&proc
->attr
, NULL
);
815 /* Otherwise the result will be passed through a union by
817 proc
->attr
.mixed_entry_master
= 1;
818 for (el
= ns
->entries
; el
; el
= el
->next
)
820 sym
= el
->sym
->result
;
821 if (sym
->attr
.dimension
)
823 if (el
== ns
->entries
)
824 gfc_error ("FUNCTION result %s can't be an array in "
825 "FUNCTION %s at %L", sym
->name
,
826 ns
->entries
->sym
->name
, &sym
->declared_at
);
828 gfc_error ("ENTRY result %s can't be an array in "
829 "FUNCTION %s at %L", sym
->name
,
830 ns
->entries
->sym
->name
, &sym
->declared_at
);
832 else if (sym
->attr
.pointer
)
834 if (el
== ns
->entries
)
835 gfc_error ("FUNCTION result %s can't be a POINTER in "
836 "FUNCTION %s at %L", sym
->name
,
837 ns
->entries
->sym
->name
, &sym
->declared_at
);
839 gfc_error ("ENTRY result %s can't be a POINTER in "
840 "FUNCTION %s at %L", sym
->name
,
841 ns
->entries
->sym
->name
, &sym
->declared_at
);
846 if (ts
->type
== BT_UNKNOWN
)
847 ts
= gfc_get_default_type (sym
->name
, NULL
);
851 if (ts
->kind
== gfc_default_integer_kind
)
855 if (ts
->kind
== gfc_default_real_kind
856 || ts
->kind
== gfc_default_double_kind
)
860 if (ts
->kind
== gfc_default_complex_kind
)
864 if (ts
->kind
== gfc_default_logical_kind
)
868 /* We will issue error elsewhere. */
876 if (el
== ns
->entries
)
877 gfc_error ("FUNCTION result %s can't be of type %s "
878 "in FUNCTION %s at %L", sym
->name
,
879 gfc_typename (ts
), ns
->entries
->sym
->name
,
882 gfc_error ("ENTRY result %s can't be of type %s "
883 "in FUNCTION %s at %L", sym
->name
,
884 gfc_typename (ts
), ns
->entries
->sym
->name
,
891 proc
->attr
.access
= ACCESS_PRIVATE
;
892 proc
->attr
.entry_master
= 1;
894 /* Merge all the entry point arguments. */
895 for (el
= ns
->entries
; el
; el
= el
->next
)
896 merge_argument_lists (proc
, el
->sym
->formal
);
898 /* Check the master formal arguments for any that are not
899 present in all entry points. */
900 for (el
= ns
->entries
; el
; el
= el
->next
)
901 check_argument_lists (proc
, el
->sym
->formal
);
903 /* Use the master function for the function body. */
904 ns
->proc_name
= proc
;
906 /* Finalize the new symbols. */
907 gfc_commit_symbols ();
909 /* Restore the original namespace. */
910 gfc_current_ns
= old_ns
;
914 /* Resolve common variables. */
916 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
918 gfc_symbol
*csym
= sym
;
920 for (; csym
; csym
= csym
->common_next
)
922 if (csym
->value
|| csym
->attr
.data
)
924 if (!csym
->ns
->is_block_data
)
925 gfc_notify_std (GFC_STD_GNU
, "Variable %qs at %L is in COMMON "
926 "but only in BLOCK DATA initialization is "
927 "allowed", csym
->name
, &csym
->declared_at
);
928 else if (!named_common
)
929 gfc_notify_std (GFC_STD_GNU
, "Initialized variable %qs at %L is "
930 "in a blank COMMON but initialization is only "
931 "allowed in named common blocks", csym
->name
,
935 if (UNLIMITED_POLY (csym
))
936 gfc_error_now ("%qs in cannot appear in COMMON at %L "
937 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
939 if (csym
->ts
.type
!= BT_DERIVED
)
942 if (!(csym
->ts
.u
.derived
->attr
.sequence
943 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
944 gfc_error_now ("Derived type variable %qs in COMMON at %L "
945 "has neither the SEQUENCE nor the BIND(C) "
946 "attribute", csym
->name
, &csym
->declared_at
);
947 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
948 gfc_error_now ("Derived type variable %qs in COMMON at %L "
949 "has an ultimate component that is "
950 "allocatable", csym
->name
, &csym
->declared_at
);
951 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
952 gfc_error_now ("Derived type variable %qs in COMMON at %L "
953 "may not have default initializer", csym
->name
,
956 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
957 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
961 /* Resolve common blocks. */
963 resolve_common_blocks (gfc_symtree
*common_root
)
968 if (common_root
== NULL
)
971 if (common_root
->left
)
972 resolve_common_blocks (common_root
->left
);
973 if (common_root
->right
)
974 resolve_common_blocks (common_root
->right
);
976 resolve_common_vars (common_root
->n
.common
->head
, true);
978 /* The common name is a global name - in Fortran 2003 also if it has a
979 C binding name, since Fortran 2008 only the C binding name is a global
981 if (!common_root
->n
.common
->binding_label
982 || gfc_notification_std (GFC_STD_F2008
))
984 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
985 common_root
->n
.common
->name
);
987 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
988 && gsym
->type
== GSYM_COMMON
989 && ((common_root
->n
.common
->binding_label
990 && (!gsym
->binding_label
991 || strcmp (common_root
->n
.common
->binding_label
,
992 gsym
->binding_label
) != 0))
993 || (!common_root
->n
.common
->binding_label
994 && gsym
->binding_label
)))
996 gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global "
997 "identifier and must thus have the same binding name "
998 "as the same-named COMMON block at %L: %s vs %s",
999 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1001 common_root
->n
.common
->binding_label
1002 ? common_root
->n
.common
->binding_label
: "(blank)",
1003 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
1007 if (gsym
&& gsym
->type
!= GSYM_COMMON
1008 && !common_root
->n
.common
->binding_label
)
1010 gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier "
1012 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1016 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1018 gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at "
1019 "%L sharing the identifier with global non-COMMON-block "
1020 "entity at %L", common_root
->n
.common
->name
,
1021 &common_root
->n
.common
->where
, &gsym
->where
);
1026 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1027 gsym
->type
= GSYM_COMMON
;
1028 gsym
->where
= common_root
->n
.common
->where
;
1034 if (common_root
->n
.common
->binding_label
)
1036 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1037 common_root
->n
.common
->binding_label
);
1038 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1040 gfc_error_1 ("COMMON block at %L with binding label %s uses the same "
1041 "global identifier as entity at %L",
1042 &common_root
->n
.common
->where
,
1043 common_root
->n
.common
->binding_label
, &gsym
->where
);
1048 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1049 gsym
->type
= GSYM_COMMON
;
1050 gsym
->where
= common_root
->n
.common
->where
;
1056 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1060 if (sym
->attr
.flavor
== FL_PARAMETER
)
1061 gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L",
1062 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1064 if (sym
->attr
.external
)
1065 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1066 sym
->name
, &common_root
->n
.common
->where
);
1068 if (sym
->attr
.intrinsic
)
1069 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1070 sym
->name
, &common_root
->n
.common
->where
);
1071 else if (sym
->attr
.result
1072 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1073 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1074 "that is also a function result", sym
->name
,
1075 &common_root
->n
.common
->where
);
1076 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1077 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1078 gfc_notify_std (GFC_STD_F2003
, "COMMON block %qs at %L "
1079 "that is also a global procedure", sym
->name
,
1080 &common_root
->n
.common
->where
);
1084 /* Resolve contained function types. Because contained functions can call one
1085 another, they have to be worked out before any of the contained procedures
1088 The good news is that if a function doesn't already have a type, the only
1089 way it can get one is through an IMPLICIT type or a RESULT variable, because
1090 by definition contained functions are contained namespace they're contained
1091 in, not in a sibling or parent namespace. */
1094 resolve_contained_functions (gfc_namespace
*ns
)
1096 gfc_namespace
*child
;
1099 resolve_formal_arglists (ns
);
1101 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1103 /* Resolve alternate entry points first. */
1104 resolve_entries (child
);
1106 /* Then check function return types. */
1107 resolve_contained_fntype (child
->proc_name
, child
);
1108 for (el
= child
->entries
; el
; el
= el
->next
)
1109 resolve_contained_fntype (el
->sym
, child
);
1114 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1117 /* Resolve all of the elements of a structure constructor and make sure that
1118 the types are correct. The 'init' flag indicates that the given
1119 constructor is an initializer. */
1122 resolve_structure_cons (gfc_expr
*expr
, int init
)
1124 gfc_constructor
*cons
;
1125 gfc_component
*comp
;
1131 if (expr
->ts
.type
== BT_DERIVED
)
1132 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1134 cons
= gfc_constructor_first (expr
->value
.constructor
);
1136 /* A constructor may have references if it is the result of substituting a
1137 parameter variable. In this case we just pull out the component we
1140 comp
= expr
->ref
->u
.c
.sym
->components
;
1142 comp
= expr
->ts
.u
.derived
->components
;
1144 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1151 if (!gfc_resolve_expr (cons
->expr
))
1157 rank
= comp
->as
? comp
->as
->rank
: 0;
1158 if (comp
->ts
.type
== BT_CLASS
&& CLASS_DATA (comp
)->as
)
1159 rank
= CLASS_DATA (comp
)->as
->rank
;
1161 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1162 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1164 gfc_error ("The rank of the element in the structure "
1165 "constructor at %L does not match that of the "
1166 "component (%d/%d)", &cons
->expr
->where
,
1167 cons
->expr
->rank
, rank
);
1171 /* If we don't have the right type, try to convert it. */
1173 if (!comp
->attr
.proc_pointer
&&
1174 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1176 if (strcmp (comp
->name
, "_extends") == 0)
1178 /* Can afford to be brutal with the _extends initializer.
1179 The derived type can get lost because it is PRIVATE
1180 but it is not usage constrained by the standard. */
1181 cons
->expr
->ts
= comp
->ts
;
1183 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1185 gfc_error ("The element in the structure constructor at %L, "
1186 "for pointer component %qs, is %s but should be %s",
1187 &cons
->expr
->where
, comp
->name
,
1188 gfc_basic_typename (cons
->expr
->ts
.type
),
1189 gfc_basic_typename (comp
->ts
.type
));
1194 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1200 /* For strings, the length of the constructor should be the same as
1201 the one of the structure, ensure this if the lengths are known at
1202 compile time and when we are dealing with PARAMETER or structure
1204 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1205 && comp
->ts
.u
.cl
->length
1206 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1207 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1208 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1209 && cons
->expr
->rank
!= 0
1210 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1211 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1213 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1214 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1216 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1217 to make use of the gfc_resolve_character_array_constructor
1218 machinery. The expression is later simplified away to
1219 an array of string literals. */
1220 gfc_expr
*para
= cons
->expr
;
1221 cons
->expr
= gfc_get_expr ();
1222 cons
->expr
->ts
= para
->ts
;
1223 cons
->expr
->where
= para
->where
;
1224 cons
->expr
->expr_type
= EXPR_ARRAY
;
1225 cons
->expr
->rank
= para
->rank
;
1226 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1227 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1228 para
, &cons
->expr
->where
);
1230 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1233 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1234 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1236 gfc_charlen
*cl
, *cl2
;
1239 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1241 if (cl
== cons
->expr
->ts
.u
.cl
)
1249 cl2
->next
= cl
->next
;
1251 gfc_free_expr (cl
->length
);
1255 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1256 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1257 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1258 gfc_resolve_character_array_constructor (cons
->expr
);
1262 if (cons
->expr
->expr_type
== EXPR_NULL
1263 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1264 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1265 || (comp
->ts
.type
== BT_CLASS
1266 && (CLASS_DATA (comp
)->attr
.class_pointer
1267 || CLASS_DATA (comp
)->attr
.allocatable
))))
1270 gfc_error ("The NULL in the structure constructor at %L is "
1271 "being applied to component %qs, which is neither "
1272 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1276 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1278 /* Check procedure pointer interface. */
1279 gfc_symbol
*s2
= NULL
;
1284 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1287 s2
= c2
->ts
.interface
;
1290 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1292 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1293 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1295 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1297 s2
= cons
->expr
->symtree
->n
.sym
;
1298 name
= cons
->expr
->symtree
->n
.sym
->name
;
1301 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1302 err
, sizeof (err
), NULL
, NULL
))
1304 gfc_error ("Interface mismatch for procedure-pointer component "
1305 "%qs in structure constructor at %L: %s",
1306 comp
->name
, &cons
->expr
->where
, err
);
1311 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1312 || cons
->expr
->expr_type
== EXPR_NULL
)
1315 a
= gfc_expr_attr (cons
->expr
);
1317 if (!a
.pointer
&& !a
.target
)
1320 gfc_error ("The element in the structure constructor at %L, "
1321 "for pointer component %qs should be a POINTER or "
1322 "a TARGET", &cons
->expr
->where
, comp
->name
);
1327 /* F08:C461. Additional checks for pointer initialization. */
1331 gfc_error ("Pointer initialization target at %L "
1332 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1337 gfc_error ("Pointer initialization target at %L "
1338 "must have the SAVE attribute", &cons
->expr
->where
);
1342 /* F2003, C1272 (3). */
1343 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1344 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1345 || gfc_is_coindexed (cons
->expr
));
1346 if (impure
&& gfc_pure (NULL
))
1349 gfc_error ("Invalid expression in the structure constructor for "
1350 "pointer component %qs at %L in PURE procedure",
1351 comp
->name
, &cons
->expr
->where
);
1355 gfc_unset_implicit_pure (NULL
);
1362 /****************** Expression name resolution ******************/
1364 /* Returns 0 if a symbol was not declared with a type or
1365 attribute declaration statement, nonzero otherwise. */
1368 was_declared (gfc_symbol
*sym
)
1374 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1377 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1378 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1379 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1380 || a
.asynchronous
|| a
.codimension
)
1387 /* Determine if a symbol is generic or not. */
1390 generic_sym (gfc_symbol
*sym
)
1394 if (sym
->attr
.generic
||
1395 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1398 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1401 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1408 return generic_sym (s
);
1415 /* Determine if a symbol is specific or not. */
1418 specific_sym (gfc_symbol
*sym
)
1422 if (sym
->attr
.if_source
== IFSRC_IFBODY
1423 || sym
->attr
.proc
== PROC_MODULE
1424 || sym
->attr
.proc
== PROC_INTERNAL
1425 || sym
->attr
.proc
== PROC_ST_FUNCTION
1426 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1427 || sym
->attr
.external
)
1430 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1433 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1435 return (s
== NULL
) ? 0 : specific_sym (s
);
1439 /* Figure out if the procedure is specific, generic or unknown. */
1442 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1446 procedure_kind (gfc_symbol
*sym
)
1448 if (generic_sym (sym
))
1449 return PTYPE_GENERIC
;
1451 if (specific_sym (sym
))
1452 return PTYPE_SPECIFIC
;
1454 return PTYPE_UNKNOWN
;
1457 /* Check references to assumed size arrays. The flag need_full_assumed_size
1458 is nonzero when matching actual arguments. */
1460 static int need_full_assumed_size
= 0;
1463 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1465 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1468 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1469 What should it be? */
1470 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1471 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1472 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1474 gfc_error ("The upper bound in the last dimension must "
1475 "appear in the reference to the assumed size "
1476 "array %qs at %L", sym
->name
, &e
->where
);
1483 /* Look for bad assumed size array references in argument expressions
1484 of elemental and array valued intrinsic procedures. Since this is
1485 called from procedure resolution functions, it only recurses at
1489 resolve_assumed_size_actual (gfc_expr
*e
)
1494 switch (e
->expr_type
)
1497 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1502 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1503 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1514 /* Check a generic procedure, passed as an actual argument, to see if
1515 there is a matching specific name. If none, it is an error, and if
1516 more than one, the reference is ambiguous. */
1518 count_specific_procs (gfc_expr
*e
)
1525 sym
= e
->symtree
->n
.sym
;
1527 for (p
= sym
->generic
; p
; p
= p
->next
)
1528 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1530 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1536 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1540 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1541 "argument at %L", sym
->name
, &e
->where
);
1547 /* See if a call to sym could possibly be a not allowed RECURSION because of
1548 a missing RECURSIVE declaration. This means that either sym is the current
1549 context itself, or sym is the parent of a contained procedure calling its
1550 non-RECURSIVE containing procedure.
1551 This also works if sym is an ENTRY. */
1554 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1556 gfc_symbol
* proc_sym
;
1557 gfc_symbol
* context_proc
;
1558 gfc_namespace
* real_context
;
1560 if (sym
->attr
.flavor
== FL_PROGRAM
1561 || sym
->attr
.flavor
== FL_DERIVED
)
1564 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1566 /* If we've got an ENTRY, find real procedure. */
1567 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1568 proc_sym
= sym
->ns
->entries
->sym
;
1572 /* If sym is RECURSIVE, all is well of course. */
1573 if (proc_sym
->attr
.recursive
|| flag_recursive
)
1576 /* Find the context procedure's "real" symbol if it has entries.
1577 We look for a procedure symbol, so recurse on the parents if we don't
1578 find one (like in case of a BLOCK construct). */
1579 for (real_context
= context
; ; real_context
= real_context
->parent
)
1581 /* We should find something, eventually! */
1582 gcc_assert (real_context
);
1584 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1585 : real_context
->proc_name
);
1587 /* In some special cases, there may not be a proc_name, like for this
1589 real(bad_kind()) function foo () ...
1590 when checking the call to bad_kind ().
1591 In these cases, we simply return here and assume that the
1596 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1600 /* A call from sym's body to itself is recursion, of course. */
1601 if (context_proc
== proc_sym
)
1604 /* The same is true if context is a contained procedure and sym the
1606 if (context_proc
->attr
.contained
)
1608 gfc_symbol
* parent_proc
;
1610 gcc_assert (context
->parent
);
1611 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1612 : context
->parent
->proc_name
);
1614 if (parent_proc
== proc_sym
)
1622 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1623 its typespec and formal argument list. */
1626 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1628 gfc_intrinsic_sym
* isym
= NULL
;
1634 /* Already resolved. */
1635 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1638 /* We already know this one is an intrinsic, so we don't call
1639 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1640 gfc_find_subroutine directly to check whether it is a function or
1643 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1645 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1646 isym
= gfc_intrinsic_subroutine_by_id (id
);
1648 else if (sym
->intmod_sym_id
)
1650 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1651 isym
= gfc_intrinsic_function_by_id (id
);
1653 else if (!sym
->attr
.subroutine
)
1654 isym
= gfc_find_function (sym
->name
);
1656 if (isym
&& !sym
->attr
.subroutine
)
1658 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1659 && !sym
->attr
.implicit_type
)
1660 gfc_warning (OPT_Wsurprising
,
1661 "Type specified for intrinsic function %qs at %L is"
1662 " ignored", sym
->name
, &sym
->declared_at
);
1664 if (!sym
->attr
.function
&&
1665 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1670 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1672 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1674 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1675 " specifier", sym
->name
, &sym
->declared_at
);
1679 if (!sym
->attr
.subroutine
&&
1680 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1685 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1690 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1692 sym
->attr
.pure
= isym
->pure
;
1693 sym
->attr
.elemental
= isym
->elemental
;
1695 /* Check it is actually available in the standard settings. */
1696 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1698 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
1699 "available in the current standard settings but %s. Use "
1700 "an appropriate %<-std=*%> option or enable "
1701 "%<-fall-intrinsics%> in order to use it.",
1702 sym
->name
, &sym
->declared_at
, symstd
);
1710 /* Resolve a procedure expression, like passing it to a called procedure or as
1711 RHS for a procedure pointer assignment. */
1714 resolve_procedure_expression (gfc_expr
* expr
)
1718 if (expr
->expr_type
!= EXPR_VARIABLE
)
1720 gcc_assert (expr
->symtree
);
1722 sym
= expr
->symtree
->n
.sym
;
1724 if (sym
->attr
.intrinsic
)
1725 gfc_resolve_intrinsic (sym
, &expr
->where
);
1727 if (sym
->attr
.flavor
!= FL_PROCEDURE
1728 || (sym
->attr
.function
&& sym
->result
== sym
))
1731 /* A non-RECURSIVE procedure that is used as procedure expression within its
1732 own body is in danger of being called recursively. */
1733 if (is_illegal_recursion (sym
, gfc_current_ns
))
1734 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
1735 " itself recursively. Declare it RECURSIVE or use"
1736 " %<-frecursive%>", sym
->name
, &expr
->where
);
1742 /* Resolve an actual argument list. Most of the time, this is just
1743 resolving the expressions in the list.
1744 The exception is that we sometimes have to decide whether arguments
1745 that look like procedure arguments are really simple variable
1749 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1750 bool no_formal_args
)
1753 gfc_symtree
*parent_st
;
1755 gfc_component
*comp
;
1756 int save_need_full_assumed_size
;
1757 bool return_value
= false;
1758 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1761 first_actual_arg
= true;
1763 for (; arg
; arg
= arg
->next
)
1768 /* Check the label is a valid branching target. */
1771 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1773 gfc_error ("Label %d referenced at %L is never defined",
1774 arg
->label
->value
, &arg
->label
->where
);
1778 first_actual_arg
= false;
1782 if (e
->expr_type
== EXPR_VARIABLE
1783 && e
->symtree
->n
.sym
->attr
.generic
1785 && count_specific_procs (e
) != 1)
1788 if (e
->ts
.type
!= BT_PROCEDURE
)
1790 save_need_full_assumed_size
= need_full_assumed_size
;
1791 if (e
->expr_type
!= EXPR_VARIABLE
)
1792 need_full_assumed_size
= 0;
1793 if (!gfc_resolve_expr (e
))
1795 need_full_assumed_size
= save_need_full_assumed_size
;
1799 /* See if the expression node should really be a variable reference. */
1801 sym
= e
->symtree
->n
.sym
;
1803 if (sym
->attr
.flavor
== FL_PROCEDURE
1804 || sym
->attr
.intrinsic
1805 || sym
->attr
.external
)
1809 /* If a procedure is not already determined to be something else
1810 check if it is intrinsic. */
1811 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1812 sym
->attr
.intrinsic
= 1;
1814 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1816 gfc_error ("Statement function %qs at %L is not allowed as an "
1817 "actual argument", sym
->name
, &e
->where
);
1820 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1821 sym
->attr
.subroutine
);
1822 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1824 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1825 "actual argument", sym
->name
, &e
->where
);
1828 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1829 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1831 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure %qs is"
1832 " used as actual argument at %L",
1833 sym
->name
, &e
->where
))
1837 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1839 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1840 "allowed as an actual argument at %L", sym
->name
,
1844 /* Check if a generic interface has a specific procedure
1845 with the same name before emitting an error. */
1846 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1849 /* Just in case a specific was found for the expression. */
1850 sym
= e
->symtree
->n
.sym
;
1852 /* If the symbol is the function that names the current (or
1853 parent) scope, then we really have a variable reference. */
1855 if (gfc_is_function_return_value (sym
, sym
->ns
))
1858 /* If all else fails, see if we have a specific intrinsic. */
1859 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1861 gfc_intrinsic_sym
*isym
;
1863 isym
= gfc_find_function (sym
->name
);
1864 if (isym
== NULL
|| !isym
->specific
)
1866 gfc_error ("Unable to find a specific INTRINSIC procedure "
1867 "for the reference %qs at %L", sym
->name
,
1872 sym
->attr
.intrinsic
= 1;
1873 sym
->attr
.function
= 1;
1876 if (!gfc_resolve_expr (e
))
1881 /* See if the name is a module procedure in a parent unit. */
1883 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1886 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1888 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1892 if (parent_st
== NULL
)
1895 sym
= parent_st
->n
.sym
;
1896 e
->symtree
= parent_st
; /* Point to the right thing. */
1898 if (sym
->attr
.flavor
== FL_PROCEDURE
1899 || sym
->attr
.intrinsic
1900 || sym
->attr
.external
)
1902 if (!gfc_resolve_expr (e
))
1908 e
->expr_type
= EXPR_VARIABLE
;
1910 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1911 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1912 && CLASS_DATA (sym
)->as
))
1914 e
->rank
= sym
->ts
.type
== BT_CLASS
1915 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1916 e
->ref
= gfc_get_ref ();
1917 e
->ref
->type
= REF_ARRAY
;
1918 e
->ref
->u
.ar
.type
= AR_FULL
;
1919 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1920 ? CLASS_DATA (sym
)->as
: sym
->as
;
1923 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1924 primary.c (match_actual_arg). If above code determines that it
1925 is a variable instead, it needs to be resolved as it was not
1926 done at the beginning of this function. */
1927 save_need_full_assumed_size
= need_full_assumed_size
;
1928 if (e
->expr_type
!= EXPR_VARIABLE
)
1929 need_full_assumed_size
= 0;
1930 if (!gfc_resolve_expr (e
))
1932 need_full_assumed_size
= save_need_full_assumed_size
;
1935 /* Check argument list functions %VAL, %LOC and %REF. There is
1936 nothing to do for %REF. */
1937 if (arg
->name
&& arg
->name
[0] == '%')
1939 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1941 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1943 gfc_error ("By-value argument at %L is not of numeric "
1950 gfc_error ("By-value argument at %L cannot be an array or "
1951 "an array section", &e
->where
);
1955 /* Intrinsics are still PROC_UNKNOWN here. However,
1956 since same file external procedures are not resolvable
1957 in gfortran, it is a good deal easier to leave them to
1959 if (ptype
!= PROC_UNKNOWN
1960 && ptype
!= PROC_DUMMY
1961 && ptype
!= PROC_EXTERNAL
1962 && ptype
!= PROC_MODULE
)
1964 gfc_error ("By-value argument at %L is not allowed "
1965 "in this context", &e
->where
);
1970 /* Statement functions have already been excluded above. */
1971 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1972 && e
->ts
.type
== BT_PROCEDURE
)
1974 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1976 gfc_error ("Passing internal procedure at %L by location "
1977 "not allowed", &e
->where
);
1983 comp
= gfc_get_proc_ptr_comp(e
);
1984 if (comp
&& comp
->attr
.elemental
)
1986 gfc_error ("ELEMENTAL procedure pointer component %qs is not "
1987 "allowed as an actual argument at %L", comp
->name
,
1991 /* Fortran 2008, C1237. */
1992 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1993 && gfc_has_ultimate_pointer (e
))
1995 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1996 "component", &e
->where
);
2000 first_actual_arg
= false;
2003 return_value
= true;
2006 actual_arg
= actual_arg_sav
;
2007 first_actual_arg
= first_actual_arg_sav
;
2009 return return_value
;
2013 /* Do the checks of the actual argument list that are specific to elemental
2014 procedures. If called with c == NULL, we have a function, otherwise if
2015 expr == NULL, we have a subroutine. */
2018 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
2020 gfc_actual_arglist
*arg0
;
2021 gfc_actual_arglist
*arg
;
2022 gfc_symbol
*esym
= NULL
;
2023 gfc_intrinsic_sym
*isym
= NULL
;
2025 gfc_intrinsic_arg
*iformal
= NULL
;
2026 gfc_formal_arglist
*eformal
= NULL
;
2027 bool formal_optional
= false;
2028 bool set_by_optional
= false;
2032 /* Is this an elemental procedure? */
2033 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2035 if (expr
->value
.function
.esym
!= NULL
2036 && expr
->value
.function
.esym
->attr
.elemental
)
2038 arg0
= expr
->value
.function
.actual
;
2039 esym
= expr
->value
.function
.esym
;
2041 else if (expr
->value
.function
.isym
!= NULL
2042 && expr
->value
.function
.isym
->elemental
)
2044 arg0
= expr
->value
.function
.actual
;
2045 isym
= expr
->value
.function
.isym
;
2050 else if (c
&& c
->ext
.actual
!= NULL
)
2052 arg0
= c
->ext
.actual
;
2054 if (c
->resolved_sym
)
2055 esym
= c
->resolved_sym
;
2057 esym
= c
->symtree
->n
.sym
;
2060 if (!esym
->attr
.elemental
)
2066 /* The rank of an elemental is the rank of its array argument(s). */
2067 for (arg
= arg0
; arg
; arg
= arg
->next
)
2069 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2071 rank
= arg
->expr
->rank
;
2072 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2073 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2074 set_by_optional
= true;
2076 /* Function specific; set the result rank and shape. */
2080 if (!expr
->shape
&& arg
->expr
->shape
)
2082 expr
->shape
= gfc_get_shape (rank
);
2083 for (i
= 0; i
< rank
; i
++)
2084 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2091 /* If it is an array, it shall not be supplied as an actual argument
2092 to an elemental procedure unless an array of the same rank is supplied
2093 as an actual argument corresponding to a nonoptional dummy argument of
2094 that elemental procedure(12.4.1.5). */
2095 formal_optional
= false;
2097 iformal
= isym
->formal
;
2099 eformal
= esym
->formal
;
2101 for (arg
= arg0
; arg
; arg
= arg
->next
)
2105 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2106 formal_optional
= true;
2107 eformal
= eformal
->next
;
2109 else if (isym
&& iformal
)
2111 if (iformal
->optional
)
2112 formal_optional
= true;
2113 iformal
= iformal
->next
;
2116 formal_optional
= true;
2118 if (pedantic
&& arg
->expr
!= NULL
2119 && arg
->expr
->expr_type
== EXPR_VARIABLE
2120 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2123 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2124 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2126 gfc_warning (0, "%qs at %L is an array and OPTIONAL; IF IT IS "
2127 "MISSING, it cannot be the actual argument of an "
2128 "ELEMENTAL procedure unless there is a non-optional "
2129 "argument with the same rank (12.4.1.5)",
2130 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2134 for (arg
= arg0
; arg
; arg
= arg
->next
)
2136 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2139 /* Being elemental, the last upper bound of an assumed size array
2140 argument must be present. */
2141 if (resolve_assumed_size_actual (arg
->expr
))
2144 /* Elemental procedure's array actual arguments must conform. */
2147 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2154 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2155 is an array, the intent inout/out variable needs to be also an array. */
2156 if (rank
> 0 && esym
&& expr
== NULL
)
2157 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2158 arg
= arg
->next
, eformal
= eformal
->next
)
2159 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2160 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2161 && arg
->expr
&& arg
->expr
->rank
== 0)
2163 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2164 "ELEMENTAL subroutine %qs is a scalar, but another "
2165 "actual argument is an array", &arg
->expr
->where
,
2166 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2167 : "INOUT", eformal
->sym
->name
, esym
->name
);
2174 /* This function does the checking of references to global procedures
2175 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2176 77 and 95 standards. It checks for a gsymbol for the name, making
2177 one if it does not already exist. If it already exists, then the
2178 reference being resolved must correspond to the type of gsymbol.
2179 Otherwise, the new symbol is equipped with the attributes of the
2180 reference. The corresponding code that is called in creating
2181 global entities is parse.c.
2183 In addition, for all but -std=legacy, the gsymbols are used to
2184 check the interfaces of external procedures from the same file.
2185 The namespace of the gsymbol is resolved and then, once this is
2186 done the interface is checked. */
2190 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2192 if (!gsym_ns
->proc_name
->attr
.recursive
)
2195 if (sym
->ns
== gsym_ns
)
2198 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2205 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2207 if (gsym_ns
->entries
)
2209 gfc_entry_list
*entry
= gsym_ns
->entries
;
2211 for (; entry
; entry
= entry
->next
)
2213 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2215 if (strcmp (gsym_ns
->proc_name
->name
,
2216 sym
->ns
->proc_name
->name
) == 0)
2220 && strcmp (gsym_ns
->proc_name
->name
,
2221 sym
->ns
->parent
->proc_name
->name
) == 0)
2230 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2233 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2235 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2237 for ( ; arg
; arg
= arg
->next
)
2242 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2244 strncpy (errmsg
, _("allocatable argument"), err_len
);
2247 else if (arg
->sym
->attr
.asynchronous
)
2249 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2252 else if (arg
->sym
->attr
.optional
)
2254 strncpy (errmsg
, _("optional argument"), err_len
);
2257 else if (arg
->sym
->attr
.pointer
)
2259 strncpy (errmsg
, _("pointer argument"), err_len
);
2262 else if (arg
->sym
->attr
.target
)
2264 strncpy (errmsg
, _("target argument"), err_len
);
2267 else if (arg
->sym
->attr
.value
)
2269 strncpy (errmsg
, _("value argument"), err_len
);
2272 else if (arg
->sym
->attr
.volatile_
)
2274 strncpy (errmsg
, _("volatile argument"), err_len
);
2277 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2279 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2282 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2284 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2287 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2289 strncpy (errmsg
, _("coarray argument"), err_len
);
2292 else if (false) /* (2d) TODO: parametrized derived type */
2294 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2297 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2299 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2302 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2304 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2307 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2309 /* As assumed-type is unlimited polymorphic (cf. above).
2310 See also TS 29113, Note 6.1. */
2311 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2316 if (sym
->attr
.function
)
2318 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2320 if (res
->attr
.dimension
) /* (3a) */
2322 strncpy (errmsg
, _("array result"), err_len
);
2325 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2327 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2330 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2331 && res
->ts
.u
.cl
->length
2332 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2334 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2339 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2341 strncpy (errmsg
, _("elemental procedure"), err_len
);
2344 else if (sym
->attr
.is_bind_c
) /* (5) */
2346 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2355 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2356 gfc_actual_arglist
**actual
, int sub
)
2360 enum gfc_symbol_type type
;
2363 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2365 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2367 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2368 gfc_global_used (gsym
, where
);
2370 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2371 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2372 && gsym
->type
!= GSYM_UNKNOWN
2373 && !gsym
->binding_label
2375 && gsym
->ns
->resolved
!= -1
2376 && gsym
->ns
->proc_name
2377 && not_in_recursive (sym
, gsym
->ns
)
2378 && not_entry_self_reference (sym
, gsym
->ns
))
2380 gfc_symbol
*def_sym
;
2382 /* Resolve the gsymbol namespace if needed. */
2383 if (!gsym
->ns
->resolved
)
2385 gfc_dt_list
*old_dt_list
;
2386 struct gfc_omp_saved_state old_omp_state
;
2388 /* Stash away derived types so that the backend_decls do not
2390 old_dt_list
= gfc_derived_types
;
2391 gfc_derived_types
= NULL
;
2392 /* And stash away openmp state. */
2393 gfc_omp_save_and_clear_state (&old_omp_state
);
2395 gfc_resolve (gsym
->ns
);
2397 /* Store the new derived types with the global namespace. */
2398 if (gfc_derived_types
)
2399 gsym
->ns
->derived_types
= gfc_derived_types
;
2401 /* Restore the derived types of this namespace. */
2402 gfc_derived_types
= old_dt_list
;
2403 /* And openmp state. */
2404 gfc_omp_restore_state (&old_omp_state
);
2407 /* Make sure that translation for the gsymbol occurs before
2408 the procedure currently being resolved. */
2409 ns
= gfc_global_ns_list
;
2410 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2412 if (ns
->sibling
== gsym
->ns
)
2414 ns
->sibling
= gsym
->ns
->sibling
;
2415 gsym
->ns
->sibling
= gfc_global_ns_list
;
2416 gfc_global_ns_list
= gsym
->ns
;
2421 def_sym
= gsym
->ns
->proc_name
;
2423 /* This can happen if a binding name has been specified. */
2424 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2425 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2427 if (def_sym
->attr
.entry_master
)
2429 gfc_entry_list
*entry
;
2430 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2431 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2433 def_sym
= entry
->sym
;
2438 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2440 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2441 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2442 gfc_typename (&def_sym
->ts
));
2446 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2447 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2449 gfc_error ("Explicit interface required for %qs at %L: %s",
2450 sym
->name
, &sym
->declared_at
, reason
);
2454 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2455 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2456 gfc_errors_to_warnings (true);
2458 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2459 reason
, sizeof(reason
), NULL
, NULL
))
2461 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2462 sym
->name
, &sym
->declared_at
, reason
);
2467 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2468 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2469 gfc_errors_to_warnings (true);
2471 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2472 gfc_procedure_use (def_sym
, actual
, where
);
2476 gfc_errors_to_warnings (false);
2478 if (gsym
->type
== GSYM_UNKNOWN
)
2481 gsym
->where
= *where
;
2488 /************* Function resolution *************/
2490 /* Resolve a function call known to be generic.
2491 Section 14.1.2.4.1. */
2494 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2498 if (sym
->attr
.generic
)
2500 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2503 expr
->value
.function
.name
= s
->name
;
2504 expr
->value
.function
.esym
= s
;
2506 if (s
->ts
.type
!= BT_UNKNOWN
)
2508 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2509 expr
->ts
= s
->result
->ts
;
2512 expr
->rank
= s
->as
->rank
;
2513 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2514 expr
->rank
= s
->result
->as
->rank
;
2516 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2521 /* TODO: Need to search for elemental references in generic
2525 if (sym
->attr
.intrinsic
)
2526 return gfc_intrinsic_func_interface (expr
, 0);
2533 resolve_generic_f (gfc_expr
*expr
)
2537 gfc_interface
*intr
= NULL
;
2539 sym
= expr
->symtree
->n
.sym
;
2543 m
= resolve_generic_f0 (expr
, sym
);
2546 else if (m
== MATCH_ERROR
)
2551 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2552 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2555 if (sym
->ns
->parent
== NULL
)
2557 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2561 if (!generic_sym (sym
))
2565 /* Last ditch attempt. See if the reference is to an intrinsic
2566 that possesses a matching interface. 14.1.2.4 */
2567 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2569 gfc_error ("There is no specific function for the generic %qs "
2570 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2576 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2579 return resolve_structure_cons (expr
, 0);
2582 m
= gfc_intrinsic_func_interface (expr
, 0);
2587 gfc_error ("Generic function %qs at %L is not consistent with a "
2588 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2595 /* Resolve a function call known to be specific. */
2598 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2602 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2604 if (sym
->attr
.dummy
)
2606 sym
->attr
.proc
= PROC_DUMMY
;
2610 sym
->attr
.proc
= PROC_EXTERNAL
;
2614 if (sym
->attr
.proc
== PROC_MODULE
2615 || sym
->attr
.proc
== PROC_ST_FUNCTION
2616 || sym
->attr
.proc
== PROC_INTERNAL
)
2619 if (sym
->attr
.intrinsic
)
2621 m
= gfc_intrinsic_func_interface (expr
, 1);
2625 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2626 "with an intrinsic", sym
->name
, &expr
->where
);
2634 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2637 expr
->ts
= sym
->result
->ts
;
2640 expr
->value
.function
.name
= sym
->name
;
2641 expr
->value
.function
.esym
= sym
;
2642 /* Prevent crash when sym->ts.u.derived->components is not set due to previous
2644 if (sym
->ts
.type
== BT_CLASS
&& !CLASS_DATA (sym
))
2646 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2647 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2648 else if (sym
->as
!= NULL
)
2649 expr
->rank
= sym
->as
->rank
;
2656 resolve_specific_f (gfc_expr
*expr
)
2661 sym
= expr
->symtree
->n
.sym
;
2665 m
= resolve_specific_f0 (sym
, expr
);
2668 if (m
== MATCH_ERROR
)
2671 if (sym
->ns
->parent
== NULL
)
2674 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2680 gfc_error ("Unable to resolve the specific function %qs at %L",
2681 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2687 /* Resolve a procedure call not known to be generic nor specific. */
2690 resolve_unknown_f (gfc_expr
*expr
)
2695 sym
= expr
->symtree
->n
.sym
;
2697 if (sym
->attr
.dummy
)
2699 sym
->attr
.proc
= PROC_DUMMY
;
2700 expr
->value
.function
.name
= sym
->name
;
2704 /* See if we have an intrinsic function reference. */
2706 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2708 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2713 /* The reference is to an external name. */
2715 sym
->attr
.proc
= PROC_EXTERNAL
;
2716 expr
->value
.function
.name
= sym
->name
;
2717 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2719 if (sym
->as
!= NULL
)
2720 expr
->rank
= sym
->as
->rank
;
2722 /* Type of the expression is either the type of the symbol or the
2723 default type of the symbol. */
2726 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2728 if (sym
->ts
.type
!= BT_UNKNOWN
)
2732 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2734 if (ts
->type
== BT_UNKNOWN
)
2736 gfc_error ("Function %qs at %L has no IMPLICIT type",
2737 sym
->name
, &expr
->where
);
2748 /* Return true, if the symbol is an external procedure. */
2750 is_external_proc (gfc_symbol
*sym
)
2752 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2753 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2754 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2755 && !sym
->attr
.proc_pointer
2756 && !sym
->attr
.use_assoc
2764 /* Figure out if a function reference is pure or not. Also set the name
2765 of the function for a potential error message. Return nonzero if the
2766 function is PURE, zero if not. */
2768 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2771 pure_function (gfc_expr
*e
, const char **name
)
2774 gfc_component
*comp
;
2778 if (e
->symtree
!= NULL
2779 && e
->symtree
->n
.sym
!= NULL
2780 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2781 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2783 comp
= gfc_get_proc_ptr_comp (e
);
2786 pure
= gfc_pure (comp
->ts
.interface
);
2789 else if (e
->value
.function
.esym
)
2791 pure
= gfc_pure (e
->value
.function
.esym
);
2792 *name
= e
->value
.function
.esym
->name
;
2794 else if (e
->value
.function
.isym
)
2796 pure
= e
->value
.function
.isym
->pure
2797 || e
->value
.function
.isym
->elemental
;
2798 *name
= e
->value
.function
.isym
->name
;
2802 /* Implicit functions are not pure. */
2804 *name
= e
->value
.function
.name
;
2812 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2813 int *f ATTRIBUTE_UNUSED
)
2817 /* Don't bother recursing into other statement functions
2818 since they will be checked individually for purity. */
2819 if (e
->expr_type
!= EXPR_FUNCTION
2821 || e
->symtree
->n
.sym
== sym
2822 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2825 return pure_function (e
, &name
) ? false : true;
2830 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2832 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2836 /* Check if an impure function is allowed in the current context. */
2838 static bool check_pure_function (gfc_expr
*e
)
2840 const char *name
= NULL
;
2841 if (!pure_function (e
, &name
) && name
)
2845 gfc_error ("Reference to impure function %qs at %L inside a "
2846 "FORALL %s", name
, &e
->where
,
2847 forall_flag
== 2 ? "mask" : "block");
2850 else if (gfc_do_concurrent_flag
)
2852 gfc_error ("Reference to impure function %qs at %L inside a "
2853 "DO CONCURRENT %s", name
, &e
->where
,
2854 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2857 else if (gfc_pure (NULL
))
2859 gfc_error ("Reference to impure function %qs at %L "
2860 "within a PURE procedure", name
, &e
->where
);
2863 gfc_unset_implicit_pure (NULL
);
2869 /* Resolve a function call, which means resolving the arguments, then figuring
2870 out which entity the name refers to. */
2873 resolve_function (gfc_expr
*expr
)
2875 gfc_actual_arglist
*arg
;
2879 procedure_type p
= PROC_INTRINSIC
;
2880 bool no_formal_args
;
2884 sym
= expr
->symtree
->n
.sym
;
2886 /* If this is a procedure pointer component, it has already been resolved. */
2887 if (gfc_is_proc_ptr_comp (expr
))
2890 if (sym
&& sym
->attr
.intrinsic
2891 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2894 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2896 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2900 /* If this ia a deferred TBP with an abstract interface (which may
2901 of course be referenced), expr->value.function.esym will be set. */
2902 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2904 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2905 sym
->name
, &expr
->where
);
2909 /* Switch off assumed size checking and do this again for certain kinds
2910 of procedure, once the procedure itself is resolved. */
2911 need_full_assumed_size
++;
2913 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2914 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2916 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2917 inquiry_argument
= true;
2918 no_formal_args
= sym
&& is_external_proc (sym
)
2919 && gfc_sym_get_dummy_args (sym
) == NULL
;
2921 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2924 inquiry_argument
= false;
2928 inquiry_argument
= false;
2930 /* Resume assumed_size checking. */
2931 need_full_assumed_size
--;
2933 /* If the procedure is external, check for usage. */
2934 if (sym
&& is_external_proc (sym
))
2935 resolve_global_procedure (sym
, &expr
->where
,
2936 &expr
->value
.function
.actual
, 0);
2938 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2940 && sym
->ts
.u
.cl
->length
== NULL
2942 && !sym
->ts
.deferred
2943 && expr
->value
.function
.esym
== NULL
2944 && !sym
->attr
.contained
)
2946 /* Internal procedures are taken care of in resolve_contained_fntype. */
2947 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2948 "be used at %L since it is not a dummy argument",
2949 sym
->name
, &expr
->where
);
2953 /* See if function is already resolved. */
2955 if (expr
->value
.function
.name
!= NULL
2956 || expr
->value
.function
.isym
!= NULL
)
2958 if (expr
->ts
.type
== BT_UNKNOWN
)
2964 /* Apply the rules of section 14.1.2. */
2966 switch (procedure_kind (sym
))
2969 t
= resolve_generic_f (expr
);
2972 case PTYPE_SPECIFIC
:
2973 t
= resolve_specific_f (expr
);
2977 t
= resolve_unknown_f (expr
);
2981 gfc_internal_error ("resolve_function(): bad function type");
2985 /* If the expression is still a function (it might have simplified),
2986 then we check to see if we are calling an elemental function. */
2988 if (expr
->expr_type
!= EXPR_FUNCTION
)
2991 temp
= need_full_assumed_size
;
2992 need_full_assumed_size
= 0;
2994 if (!resolve_elemental_actual (expr
, NULL
))
2997 if (omp_workshare_flag
2998 && expr
->value
.function
.esym
2999 && ! gfc_elemental (expr
->value
.function
.esym
))
3001 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
3002 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3007 #define GENERIC_ID expr->value.function.isym->id
3008 else if (expr
->value
.function
.actual
!= NULL
3009 && expr
->value
.function
.isym
!= NULL
3010 && GENERIC_ID
!= GFC_ISYM_LBOUND
3011 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
3012 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
3013 && GENERIC_ID
!= GFC_ISYM_LEN
3014 && GENERIC_ID
!= GFC_ISYM_LOC
3015 && GENERIC_ID
!= GFC_ISYM_C_LOC
3016 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3018 /* Array intrinsics must also have the last upper bound of an
3019 assumed size array argument. UBOUND and SIZE have to be
3020 excluded from the check if the second argument is anything
3023 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3025 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3026 && arg
== expr
->value
.function
.actual
3027 && arg
->next
!= NULL
&& arg
->next
->expr
)
3029 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3032 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
3035 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3040 if (arg
->expr
!= NULL
3041 && arg
->expr
->rank
> 0
3042 && resolve_assumed_size_actual (arg
->expr
))
3048 need_full_assumed_size
= temp
;
3050 if (!check_pure_function(expr
))
3053 /* Functions without the RECURSIVE attribution are not allowed to
3054 * call themselves. */
3055 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3058 esym
= expr
->value
.function
.esym
;
3060 if (is_illegal_recursion (esym
, gfc_current_ns
))
3062 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3063 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3064 " function %qs is not RECURSIVE",
3065 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3067 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3068 " is not RECURSIVE", esym
->name
, &expr
->where
);
3074 /* Character lengths of use associated functions may contains references to
3075 symbols not referenced from the current program unit otherwise. Make sure
3076 those symbols are marked as referenced. */
3078 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3079 && expr
->value
.function
.esym
->attr
.use_assoc
)
3081 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3084 /* Make sure that the expression has a typespec that works. */
3085 if (expr
->ts
.type
== BT_UNKNOWN
)
3087 if (expr
->symtree
->n
.sym
->result
3088 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3089 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3090 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3097 /************* Subroutine resolution *************/
3100 pure_subroutine (gfc_symbol
*sym
, const char *name
, locus
*loc
)
3107 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3111 else if (gfc_do_concurrent_flag
)
3113 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3117 else if (gfc_pure (NULL
))
3119 gfc_error ("Subroutine call to %qs at %L is not PURE", name
, loc
);
3123 gfc_unset_implicit_pure (NULL
);
3129 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3133 if (sym
->attr
.generic
)
3135 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3138 c
->resolved_sym
= s
;
3139 if (!pure_subroutine (s
, s
->name
, &c
->loc
))
3144 /* TODO: Need to search for elemental references in generic interface. */
3147 if (sym
->attr
.intrinsic
)
3148 return gfc_intrinsic_sub_interface (c
, 0);
3155 resolve_generic_s (gfc_code
*c
)
3160 sym
= c
->symtree
->n
.sym
;
3164 m
= resolve_generic_s0 (c
, sym
);
3167 else if (m
== MATCH_ERROR
)
3171 if (sym
->ns
->parent
== NULL
)
3173 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3177 if (!generic_sym (sym
))
3181 /* Last ditch attempt. See if the reference is to an intrinsic
3182 that possesses a matching interface. 14.1.2.4 */
3183 sym
= c
->symtree
->n
.sym
;
3185 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3187 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3188 sym
->name
, &c
->loc
);
3192 m
= gfc_intrinsic_sub_interface (c
, 0);
3196 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3197 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3203 /* Resolve a subroutine call known to be specific. */
3206 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3210 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3212 if (sym
->attr
.dummy
)
3214 sym
->attr
.proc
= PROC_DUMMY
;
3218 sym
->attr
.proc
= PROC_EXTERNAL
;
3222 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3225 if (sym
->attr
.intrinsic
)
3227 m
= gfc_intrinsic_sub_interface (c
, 1);
3231 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3232 "with an intrinsic", sym
->name
, &c
->loc
);
3240 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3242 c
->resolved_sym
= sym
;
3243 if (!pure_subroutine (sym
, sym
->name
, &c
->loc
))
3251 resolve_specific_s (gfc_code
*c
)
3256 sym
= c
->symtree
->n
.sym
;
3260 m
= resolve_specific_s0 (c
, sym
);
3263 if (m
== MATCH_ERROR
)
3266 if (sym
->ns
->parent
== NULL
)
3269 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3275 sym
= c
->symtree
->n
.sym
;
3276 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3277 sym
->name
, &c
->loc
);
3283 /* Resolve a subroutine call not known to be generic nor specific. */
3286 resolve_unknown_s (gfc_code
*c
)
3290 sym
= c
->symtree
->n
.sym
;
3292 if (sym
->attr
.dummy
)
3294 sym
->attr
.proc
= PROC_DUMMY
;
3298 /* See if we have an intrinsic function reference. */
3300 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3302 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3307 /* The reference is to an external name. */
3310 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3312 c
->resolved_sym
= sym
;
3314 return pure_subroutine (sym
, sym
->name
, &c
->loc
);
3318 /* Resolve a subroutine call. Although it was tempting to use the same code
3319 for functions, subroutines and functions are stored differently and this
3320 makes things awkward. */
3323 resolve_call (gfc_code
*c
)
3326 procedure_type ptype
= PROC_INTRINSIC
;
3327 gfc_symbol
*csym
, *sym
;
3328 bool no_formal_args
;
3330 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3332 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3334 gfc_error_1 ("'%s' at %L has a type, which is not consistent with "
3335 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3339 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3342 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3343 sym
= st
? st
->n
.sym
: NULL
;
3344 if (sym
&& csym
!= sym
3345 && sym
->ns
== gfc_current_ns
3346 && sym
->attr
.flavor
== FL_PROCEDURE
3347 && sym
->attr
.contained
)
3350 if (csym
->attr
.generic
)
3351 c
->symtree
->n
.sym
= sym
;
3354 csym
= c
->symtree
->n
.sym
;
3358 /* If this ia a deferred TBP, c->expr1 will be set. */
3359 if (!c
->expr1
&& csym
)
3361 if (csym
->attr
.abstract
)
3363 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3364 csym
->name
, &c
->loc
);
3368 /* Subroutines without the RECURSIVE attribution are not allowed to
3370 if (is_illegal_recursion (csym
, gfc_current_ns
))
3372 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3373 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3374 "as subroutine %qs is not RECURSIVE",
3375 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3377 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3378 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3384 /* Switch off assumed size checking and do this again for certain kinds
3385 of procedure, once the procedure itself is resolved. */
3386 need_full_assumed_size
++;
3389 ptype
= csym
->attr
.proc
;
3391 no_formal_args
= csym
&& is_external_proc (csym
)
3392 && gfc_sym_get_dummy_args (csym
) == NULL
;
3393 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3396 /* Resume assumed_size checking. */
3397 need_full_assumed_size
--;
3399 /* If external, check for usage. */
3400 if (csym
&& is_external_proc (csym
))
3401 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3404 if (c
->resolved_sym
== NULL
)
3406 c
->resolved_isym
= NULL
;
3407 switch (procedure_kind (csym
))
3410 t
= resolve_generic_s (c
);
3413 case PTYPE_SPECIFIC
:
3414 t
= resolve_specific_s (c
);
3418 t
= resolve_unknown_s (c
);
3422 gfc_internal_error ("resolve_subroutine(): bad function type");
3426 /* Some checks of elemental subroutine actual arguments. */
3427 if (!resolve_elemental_actual (NULL
, c
))
3434 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3435 op1->shape and op2->shape are non-NULL return true if their shapes
3436 match. If both op1->shape and op2->shape are non-NULL return false
3437 if their shapes do not match. If either op1->shape or op2->shape is
3438 NULL, return true. */
3441 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3448 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3450 for (i
= 0; i
< op1
->rank
; i
++)
3452 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3454 gfc_error_1 ("Shapes for operands at %L and %L are not conformable",
3455 &op1
->where
, &op2
->where
);
3466 /* Resolve an operator expression node. This can involve replacing the
3467 operation with a user defined function call. */
3470 resolve_operator (gfc_expr
*e
)
3472 gfc_expr
*op1
, *op2
;
3474 bool dual_locus_error
;
3477 /* Resolve all subnodes-- give them types. */
3479 switch (e
->value
.op
.op
)
3482 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3485 /* Fall through... */
3488 case INTRINSIC_UPLUS
:
3489 case INTRINSIC_UMINUS
:
3490 case INTRINSIC_PARENTHESES
:
3491 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3496 /* Typecheck the new node. */
3498 op1
= e
->value
.op
.op1
;
3499 op2
= e
->value
.op
.op2
;
3500 dual_locus_error
= false;
3502 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3503 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3505 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3509 switch (e
->value
.op
.op
)
3511 case INTRINSIC_UPLUS
:
3512 case INTRINSIC_UMINUS
:
3513 if (op1
->ts
.type
== BT_INTEGER
3514 || op1
->ts
.type
== BT_REAL
3515 || op1
->ts
.type
== BT_COMPLEX
)
3521 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3522 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3525 case INTRINSIC_PLUS
:
3526 case INTRINSIC_MINUS
:
3527 case INTRINSIC_TIMES
:
3528 case INTRINSIC_DIVIDE
:
3529 case INTRINSIC_POWER
:
3530 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3532 gfc_type_convert_binary (e
, 1);
3537 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3538 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3539 gfc_typename (&op2
->ts
));
3542 case INTRINSIC_CONCAT
:
3543 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3544 && op1
->ts
.kind
== op2
->ts
.kind
)
3546 e
->ts
.type
= BT_CHARACTER
;
3547 e
->ts
.kind
= op1
->ts
.kind
;
3552 _("Operands of string concatenation operator at %%L are %s/%s"),
3553 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3559 case INTRINSIC_NEQV
:
3560 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3562 e
->ts
.type
= BT_LOGICAL
;
3563 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3564 if (op1
->ts
.kind
< e
->ts
.kind
)
3565 gfc_convert_type (op1
, &e
->ts
, 2);
3566 else if (op2
->ts
.kind
< e
->ts
.kind
)
3567 gfc_convert_type (op2
, &e
->ts
, 2);
3571 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3572 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3573 gfc_typename (&op2
->ts
));
3578 if (op1
->ts
.type
== BT_LOGICAL
)
3580 e
->ts
.type
= BT_LOGICAL
;
3581 e
->ts
.kind
= op1
->ts
.kind
;
3585 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3586 gfc_typename (&op1
->ts
));
3590 case INTRINSIC_GT_OS
:
3592 case INTRINSIC_GE_OS
:
3594 case INTRINSIC_LT_OS
:
3596 case INTRINSIC_LE_OS
:
3597 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3599 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3603 /* Fall through... */
3606 case INTRINSIC_EQ_OS
:
3608 case INTRINSIC_NE_OS
:
3609 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3610 && op1
->ts
.kind
== op2
->ts
.kind
)
3612 e
->ts
.type
= BT_LOGICAL
;
3613 e
->ts
.kind
= gfc_default_logical_kind
;
3617 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3619 gfc_type_convert_binary (e
, 1);
3621 e
->ts
.type
= BT_LOGICAL
;
3622 e
->ts
.kind
= gfc_default_logical_kind
;
3624 if (warn_compare_reals
)
3626 gfc_intrinsic_op op
= e
->value
.op
.op
;
3628 /* Type conversion has made sure that the types of op1 and op2
3629 agree, so it is only necessary to check the first one. */
3630 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3631 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3632 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3636 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3637 msg
= "Equality comparison for %s at %L";
3639 msg
= "Inequality comparison for %s at %L";
3641 gfc_warning (0, msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3648 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3650 _("Logicals at %%L must be compared with %s instead of %s"),
3651 (e
->value
.op
.op
== INTRINSIC_EQ
3652 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3653 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3656 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3657 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3658 gfc_typename (&op2
->ts
));
3662 case INTRINSIC_USER
:
3663 if (e
->value
.op
.uop
->op
== NULL
)
3664 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3665 else if (op2
== NULL
)
3666 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3667 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3670 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3671 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3672 gfc_typename (&op2
->ts
));
3673 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3678 case INTRINSIC_PARENTHESES
:
3680 if (e
->ts
.type
== BT_CHARACTER
)
3681 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3685 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3688 /* Deal with arrayness of an operand through an operator. */
3692 switch (e
->value
.op
.op
)
3694 case INTRINSIC_PLUS
:
3695 case INTRINSIC_MINUS
:
3696 case INTRINSIC_TIMES
:
3697 case INTRINSIC_DIVIDE
:
3698 case INTRINSIC_POWER
:
3699 case INTRINSIC_CONCAT
:
3703 case INTRINSIC_NEQV
:
3705 case INTRINSIC_EQ_OS
:
3707 case INTRINSIC_NE_OS
:
3709 case INTRINSIC_GT_OS
:
3711 case INTRINSIC_GE_OS
:
3713 case INTRINSIC_LT_OS
:
3715 case INTRINSIC_LE_OS
:
3717 if (op1
->rank
== 0 && op2
->rank
== 0)
3720 if (op1
->rank
== 0 && op2
->rank
!= 0)
3722 e
->rank
= op2
->rank
;
3724 if (e
->shape
== NULL
)
3725 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3728 if (op1
->rank
!= 0 && op2
->rank
== 0)
3730 e
->rank
= op1
->rank
;
3732 if (e
->shape
== NULL
)
3733 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3736 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3738 if (op1
->rank
== op2
->rank
)
3740 e
->rank
= op1
->rank
;
3741 if (e
->shape
== NULL
)
3743 t
= compare_shapes (op1
, op2
);
3747 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3752 /* Allow higher level expressions to work. */
3755 /* Try user-defined operators, and otherwise throw an error. */
3756 dual_locus_error
= true;
3758 _("Inconsistent ranks for operator at %%L and %%L"));
3765 case INTRINSIC_PARENTHESES
:
3767 case INTRINSIC_UPLUS
:
3768 case INTRINSIC_UMINUS
:
3769 /* Simply copy arrayness attribute */
3770 e
->rank
= op1
->rank
;
3772 if (e
->shape
== NULL
)
3773 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3781 /* Attempt to simplify the expression. */
3784 t
= gfc_simplify_expr (e
, 0);
3785 /* Some calls do not succeed in simplification and return false
3786 even though there is no error; e.g. variable references to
3787 PARAMETER arrays. */
3788 if (!gfc_is_constant_expr (e
))
3796 match m
= gfc_extend_expr (e
);
3799 if (m
== MATCH_ERROR
)
3803 if (dual_locus_error
)
3804 gfc_error (msg
, &op1
->where
, &op2
->where
);
3806 gfc_error (msg
, &e
->where
);
3812 /************** Array resolution subroutines **************/
3815 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3818 /* Compare two integer expressions. */
3820 static compare_result
3821 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3825 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3826 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3829 /* If either of the types isn't INTEGER, we must have
3830 raised an error earlier. */
3832 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3835 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3845 /* Compare an integer expression with an integer. */
3847 static compare_result
3848 compare_bound_int (gfc_expr
*a
, int b
)
3852 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3855 if (a
->ts
.type
!= BT_INTEGER
)
3856 gfc_internal_error ("compare_bound_int(): Bad expression");
3858 i
= mpz_cmp_si (a
->value
.integer
, b
);
3868 /* Compare an integer expression with a mpz_t. */
3870 static compare_result
3871 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3875 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3878 if (a
->ts
.type
!= BT_INTEGER
)
3879 gfc_internal_error ("compare_bound_int(): Bad expression");
3881 i
= mpz_cmp (a
->value
.integer
, b
);
3891 /* Compute the last value of a sequence given by a triplet.
3892 Return 0 if it wasn't able to compute the last value, or if the
3893 sequence if empty, and 1 otherwise. */
3896 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3897 gfc_expr
*stride
, mpz_t last
)
3901 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3902 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3903 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3906 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3907 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3910 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3912 if (compare_bound (start
, end
) == CMP_GT
)
3914 mpz_set (last
, end
->value
.integer
);
3918 if (compare_bound_int (stride
, 0) == CMP_GT
)
3920 /* Stride is positive */
3921 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3926 /* Stride is negative */
3927 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3932 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3933 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3934 mpz_sub (last
, end
->value
.integer
, rem
);
3941 /* Compare a single dimension of an array reference to the array
3945 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3949 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3951 gcc_assert (ar
->stride
[i
] == NULL
);
3952 /* This implies [*] as [*:] and [*:3] are not possible. */
3953 if (ar
->start
[i
] == NULL
)
3955 gcc_assert (ar
->end
[i
] == NULL
);
3960 /* Given start, end and stride values, calculate the minimum and
3961 maximum referenced indexes. */
3963 switch (ar
->dimen_type
[i
])
3966 case DIMEN_THIS_IMAGE
:
3971 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3974 gfc_warning (0, "Array reference at %L is out of bounds "
3975 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3976 mpz_get_si (ar
->start
[i
]->value
.integer
),
3977 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3979 gfc_warning (0, "Array reference at %L is out of bounds "
3980 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3981 mpz_get_si (ar
->start
[i
]->value
.integer
),
3982 mpz_get_si (as
->lower
[i
]->value
.integer
),
3986 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3989 gfc_warning (0, "Array reference at %L is out of bounds "
3990 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3991 mpz_get_si (ar
->start
[i
]->value
.integer
),
3992 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3994 gfc_warning (0, "Array reference at %L is out of bounds "
3995 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3996 mpz_get_si (ar
->start
[i
]->value
.integer
),
3997 mpz_get_si (as
->upper
[i
]->value
.integer
),
4006 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4007 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4009 compare_result comp_start_end
= compare_bound (AR_START
, AR_END
);
4011 /* Check for zero stride, which is not allowed. */
4012 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4014 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4018 /* if start == len || (stride > 0 && start < len)
4019 || (stride < 0 && start > len),
4020 then the array section contains at least one element. In this
4021 case, there is an out-of-bounds access if
4022 (start < lower || start > upper). */
4023 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4024 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4025 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4026 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4027 && comp_start_end
== CMP_GT
))
4029 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4031 gfc_warning (0, "Lower array reference at %L is out of bounds "
4032 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4033 mpz_get_si (AR_START
->value
.integer
),
4034 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4037 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4039 gfc_warning (0, "Lower array reference at %L is out of bounds "
4040 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4041 mpz_get_si (AR_START
->value
.integer
),
4042 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4047 /* If we can compute the highest index of the array section,
4048 then it also has to be between lower and upper. */
4049 mpz_init (last_value
);
4050 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4053 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4055 gfc_warning (0, "Upper array reference at %L is out of bounds "
4056 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4057 mpz_get_si (last_value
),
4058 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4059 mpz_clear (last_value
);
4062 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4064 gfc_warning (0, "Upper array reference at %L is out of bounds "
4065 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4066 mpz_get_si (last_value
),
4067 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4068 mpz_clear (last_value
);
4072 mpz_clear (last_value
);
4080 gfc_internal_error ("check_dimension(): Bad array reference");
4087 /* Compare an array reference with an array specification. */
4090 compare_spec_to_ref (gfc_array_ref
*ar
)
4097 /* TODO: Full array sections are only allowed as actual parameters. */
4098 if (as
->type
== AS_ASSUMED_SIZE
4099 && (/*ar->type == AR_FULL
4100 ||*/ (ar
->type
== AR_SECTION
4101 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4103 gfc_error ("Rightmost upper bound of assumed size array section "
4104 "not specified at %L", &ar
->where
);
4108 if (ar
->type
== AR_FULL
)
4111 if (as
->rank
!= ar
->dimen
)
4113 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4114 &ar
->where
, ar
->dimen
, as
->rank
);
4118 /* ar->codimen == 0 is a local array. */
4119 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4121 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4122 &ar
->where
, ar
->codimen
, as
->corank
);
4126 for (i
= 0; i
< as
->rank
; i
++)
4127 if (!check_dimension (i
, ar
, as
))
4130 /* Local access has no coarray spec. */
4131 if (ar
->codimen
!= 0)
4132 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4134 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4135 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4137 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4138 i
+ 1 - as
->rank
, &ar
->where
);
4141 if (!check_dimension (i
, ar
, as
))
4149 /* Resolve one part of an array index. */
4152 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4153 int force_index_integer_kind
)
4160 if (!gfc_resolve_expr (index
))
4163 if (check_scalar
&& index
->rank
!= 0)
4165 gfc_error ("Array index at %L must be scalar", &index
->where
);
4169 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4171 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4172 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4176 if (index
->ts
.type
== BT_REAL
)
4177 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4181 if ((index
->ts
.kind
!= gfc_index_integer_kind
4182 && force_index_integer_kind
)
4183 || index
->ts
.type
!= BT_INTEGER
)
4186 ts
.type
= BT_INTEGER
;
4187 ts
.kind
= gfc_index_integer_kind
;
4189 gfc_convert_type_warn (index
, &ts
, 2, 0);
4195 /* Resolve one part of an array index. */
4198 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4200 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4203 /* Resolve a dim argument to an intrinsic function. */
4206 gfc_resolve_dim_arg (gfc_expr
*dim
)
4211 if (!gfc_resolve_expr (dim
))
4216 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4221 if (dim
->ts
.type
!= BT_INTEGER
)
4223 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4227 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4232 ts
.type
= BT_INTEGER
;
4233 ts
.kind
= gfc_index_integer_kind
;
4235 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4241 /* Given an expression that contains array references, update those array
4242 references to point to the right array specifications. While this is
4243 filled in during matching, this information is difficult to save and load
4244 in a module, so we take care of it here.
4246 The idea here is that the original array reference comes from the
4247 base symbol. We traverse the list of reference structures, setting
4248 the stored reference to references. Component references can
4249 provide an additional array specification. */
4252 find_array_spec (gfc_expr
*e
)
4258 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4259 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4261 as
= e
->symtree
->n
.sym
->as
;
4263 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4268 gfc_internal_error ("find_array_spec(): Missing spec");
4275 c
= ref
->u
.c
.component
;
4276 if (c
->attr
.dimension
)
4279 gfc_internal_error ("find_array_spec(): unused as(1)");
4290 gfc_internal_error ("find_array_spec(): unused as(2)");
4294 /* Resolve an array reference. */
4297 resolve_array_ref (gfc_array_ref
*ar
)
4299 int i
, check_scalar
;
4302 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4304 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4306 /* Do not force gfc_index_integer_kind for the start. We can
4307 do fine with any integer kind. This avoids temporary arrays
4308 created for indexing with a vector. */
4309 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4311 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4313 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4318 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4322 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4326 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4327 if (e
->expr_type
== EXPR_VARIABLE
4328 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4329 ar
->start
[i
] = gfc_get_parentheses (e
);
4333 gfc_error ("Array index at %L is an array of rank %d",
4334 &ar
->c_where
[i
], e
->rank
);
4338 /* Fill in the upper bound, which may be lower than the
4339 specified one for something like a(2:10:5), which is
4340 identical to a(2:7:5). Only relevant for strides not equal
4341 to one. Don't try a division by zero. */
4342 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4343 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4344 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4345 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4349 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4351 if (ar
->end
[i
] == NULL
)
4354 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4356 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4358 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4359 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4361 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4372 if (ar
->type
== AR_FULL
)
4374 if (ar
->as
->rank
== 0)
4375 ar
->type
= AR_ELEMENT
;
4377 /* Make sure array is the same as array(:,:), this way
4378 we don't need to special case all the time. */
4379 ar
->dimen
= ar
->as
->rank
;
4380 for (i
= 0; i
< ar
->dimen
; i
++)
4382 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4384 gcc_assert (ar
->start
[i
] == NULL
);
4385 gcc_assert (ar
->end
[i
] == NULL
);
4386 gcc_assert (ar
->stride
[i
] == NULL
);
4390 /* If the reference type is unknown, figure out what kind it is. */
4392 if (ar
->type
== AR_UNKNOWN
)
4394 ar
->type
= AR_ELEMENT
;
4395 for (i
= 0; i
< ar
->dimen
; i
++)
4396 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4397 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4399 ar
->type
= AR_SECTION
;
4404 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4407 if (ar
->as
->corank
&& ar
->codimen
== 0)
4410 ar
->codimen
= ar
->as
->corank
;
4411 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4412 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4420 resolve_substring (gfc_ref
*ref
)
4422 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4424 if (ref
->u
.ss
.start
!= NULL
)
4426 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4429 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4431 gfc_error ("Substring start index at %L must be of type INTEGER",
4432 &ref
->u
.ss
.start
->where
);
4436 if (ref
->u
.ss
.start
->rank
!= 0)
4438 gfc_error ("Substring start index at %L must be scalar",
4439 &ref
->u
.ss
.start
->where
);
4443 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4444 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4445 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4447 gfc_error ("Substring start index at %L is less than one",
4448 &ref
->u
.ss
.start
->where
);
4453 if (ref
->u
.ss
.end
!= NULL
)
4455 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4458 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4460 gfc_error ("Substring end index at %L must be of type INTEGER",
4461 &ref
->u
.ss
.end
->where
);
4465 if (ref
->u
.ss
.end
->rank
!= 0)
4467 gfc_error ("Substring end index at %L must be scalar",
4468 &ref
->u
.ss
.end
->where
);
4472 if (ref
->u
.ss
.length
!= NULL
4473 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4474 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4475 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4477 gfc_error ("Substring end index at %L exceeds the string length",
4478 &ref
->u
.ss
.start
->where
);
4482 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4483 gfc_integer_kinds
[k
].huge
) == CMP_GT
4484 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4485 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4487 gfc_error ("Substring end index at %L is too large",
4488 &ref
->u
.ss
.end
->where
);
4497 /* This function supplies missing substring charlens. */
4500 gfc_resolve_substring_charlen (gfc_expr
*e
)
4503 gfc_expr
*start
, *end
;
4505 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4506 if (char_ref
->type
== REF_SUBSTRING
)
4512 gcc_assert (char_ref
->next
== NULL
);
4516 if (e
->ts
.u
.cl
->length
)
4517 gfc_free_expr (e
->ts
.u
.cl
->length
);
4518 else if (e
->expr_type
== EXPR_VARIABLE
4519 && e
->symtree
->n
.sym
->attr
.dummy
)
4523 e
->ts
.type
= BT_CHARACTER
;
4524 e
->ts
.kind
= gfc_default_character_kind
;
4527 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4529 if (char_ref
->u
.ss
.start
)
4530 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4532 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4534 if (char_ref
->u
.ss
.end
)
4535 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4536 else if (e
->expr_type
== EXPR_VARIABLE
)
4537 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4543 gfc_free_expr (start
);
4544 gfc_free_expr (end
);
4548 /* Length = (end - start +1). */
4549 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4550 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4551 gfc_get_int_expr (gfc_default_integer_kind
,
4554 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4555 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4557 /* Make sure that the length is simplified. */
4558 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4559 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4563 /* Resolve subtype references. */
4566 resolve_ref (gfc_expr
*expr
)
4568 int current_part_dimension
, n_components
, seen_part_dimension
;
4571 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4572 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4574 find_array_spec (expr
);
4578 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4582 if (!resolve_array_ref (&ref
->u
.ar
))
4590 if (!resolve_substring (ref
))
4595 /* Check constraints on part references. */
4597 current_part_dimension
= 0;
4598 seen_part_dimension
= 0;
4601 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4606 switch (ref
->u
.ar
.type
)
4609 /* Coarray scalar. */
4610 if (ref
->u
.ar
.as
->rank
== 0)
4612 current_part_dimension
= 0;
4617 current_part_dimension
= 1;
4621 current_part_dimension
= 0;
4625 gfc_internal_error ("resolve_ref(): Bad array reference");
4631 if (current_part_dimension
|| seen_part_dimension
)
4634 if (ref
->u
.c
.component
->attr
.pointer
4635 || ref
->u
.c
.component
->attr
.proc_pointer
4636 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4637 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4639 gfc_error ("Component to the right of a part reference "
4640 "with nonzero rank must not have the POINTER "
4641 "attribute at %L", &expr
->where
);
4644 else if (ref
->u
.c
.component
->attr
.allocatable
4645 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4646 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4649 gfc_error ("Component to the right of a part reference "
4650 "with nonzero rank must not have the ALLOCATABLE "
4651 "attribute at %L", &expr
->where
);
4663 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4664 || ref
->next
== NULL
)
4665 && current_part_dimension
4666 && seen_part_dimension
)
4668 gfc_error ("Two or more part references with nonzero rank must "
4669 "not be specified at %L", &expr
->where
);
4673 if (ref
->type
== REF_COMPONENT
)
4675 if (current_part_dimension
)
4676 seen_part_dimension
= 1;
4678 /* reset to make sure */
4679 current_part_dimension
= 0;
4687 /* Given an expression, determine its shape. This is easier than it sounds.
4688 Leaves the shape array NULL if it is not possible to determine the shape. */
4691 expression_shape (gfc_expr
*e
)
4693 mpz_t array
[GFC_MAX_DIMENSIONS
];
4696 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4699 for (i
= 0; i
< e
->rank
; i
++)
4700 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4703 e
->shape
= gfc_get_shape (e
->rank
);
4705 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4710 for (i
--; i
>= 0; i
--)
4711 mpz_clear (array
[i
]);
4715 /* Given a variable expression node, compute the rank of the expression by
4716 examining the base symbol and any reference structures it may have. */
4719 expression_rank (gfc_expr
*e
)
4724 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4725 could lead to serious confusion... */
4726 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4730 if (e
->expr_type
== EXPR_ARRAY
)
4732 /* Constructors can have a rank different from one via RESHAPE(). */
4734 if (e
->symtree
== NULL
)
4740 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4741 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4747 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4749 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4750 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4751 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4753 if (ref
->type
!= REF_ARRAY
)
4756 if (ref
->u
.ar
.type
== AR_FULL
)
4758 rank
= ref
->u
.ar
.as
->rank
;
4762 if (ref
->u
.ar
.type
== AR_SECTION
)
4764 /* Figure out the rank of the section. */
4766 gfc_internal_error ("expression_rank(): Two array specs");
4768 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4769 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4770 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4780 expression_shape (e
);
4785 add_caf_get_intrinsic (gfc_expr
*e
)
4787 gfc_expr
*wrapper
, *tmp_expr
;
4791 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4792 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4797 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4798 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4801 tmp_expr
= XCNEW (gfc_expr
);
4803 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4804 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4805 wrapper
->ts
= e
->ts
;
4806 wrapper
->rank
= e
->rank
;
4808 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4815 remove_caf_get_intrinsic (gfc_expr
*e
)
4817 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4818 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4819 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4820 e
->value
.function
.actual
->expr
= NULL
;
4821 gfc_free_actual_arglist (e
->value
.function
.actual
);
4822 gfc_free_shape (&e
->shape
, e
->rank
);
4828 /* Resolve a variable expression. */
4831 resolve_variable (gfc_expr
*e
)
4838 if (e
->symtree
== NULL
)
4840 sym
= e
->symtree
->n
.sym
;
4842 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4843 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4844 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4846 if (!actual_arg
|| inquiry_argument
)
4848 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4849 "be used as actual argument", sym
->name
, &e
->where
);
4853 /* TS 29113, 407b. */
4854 else if (e
->ts
.type
== BT_ASSUMED
)
4858 gfc_error ("Assumed-type variable %s at %L may only be used "
4859 "as actual argument", sym
->name
, &e
->where
);
4862 else if (inquiry_argument
&& !first_actual_arg
)
4864 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4865 for all inquiry functions in resolve_function; the reason is
4866 that the function-name resolution happens too late in that
4868 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4869 "an inquiry function shall be the first argument",
4870 sym
->name
, &e
->where
);
4874 /* TS 29113, C535b. */
4875 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4876 && CLASS_DATA (sym
)->as
4877 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4878 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4879 && sym
->as
->type
== AS_ASSUMED_RANK
))
4883 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4884 "actual argument", sym
->name
, &e
->where
);
4887 else if (inquiry_argument
&& !first_actual_arg
)
4889 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4890 for all inquiry functions in resolve_function; the reason is
4891 that the function-name resolution happens too late in that
4893 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4894 "to an inquiry function shall be the first argument",
4895 sym
->name
, &e
->where
);
4900 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4901 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4902 && e
->ref
->next
== NULL
))
4904 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4905 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4908 /* TS 29113, 407b. */
4909 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4910 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4911 && e
->ref
->next
== NULL
))
4913 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4914 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4918 /* TS 29113, C535b. */
4919 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4920 && CLASS_DATA (sym
)->as
4921 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4922 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4923 && sym
->as
->type
== AS_ASSUMED_RANK
))
4925 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4926 && e
->ref
->next
== NULL
))
4928 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4929 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4934 /* If this is an associate-name, it may be parsed with an array reference
4935 in error even though the target is scalar. Fail directly in this case.
4936 TODO Understand why class scalar expressions must be excluded. */
4937 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4939 if (sym
->ts
.type
== BT_CLASS
)
4940 gfc_fix_class_refs (e
);
4941 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4945 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4946 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4948 /* On the other hand, the parser may not have known this is an array;
4949 in this case, we have to add a FULL reference. */
4950 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4952 e
->ref
= gfc_get_ref ();
4953 e
->ref
->type
= REF_ARRAY
;
4954 e
->ref
->u
.ar
.type
= AR_FULL
;
4955 e
->ref
->u
.ar
.dimen
= 0;
4958 if (e
->ref
&& !resolve_ref (e
))
4961 if (sym
->attr
.flavor
== FL_PROCEDURE
4962 && (!sym
->attr
.function
4963 || (sym
->attr
.function
&& sym
->result
4964 && sym
->result
->attr
.proc_pointer
4965 && !sym
->result
->attr
.function
)))
4967 e
->ts
.type
= BT_PROCEDURE
;
4968 goto resolve_procedure
;
4971 if (sym
->ts
.type
!= BT_UNKNOWN
)
4972 gfc_variable_attr (e
, &e
->ts
);
4975 /* Must be a simple variable reference. */
4976 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4981 if (check_assumed_size_reference (sym
, e
))
4984 /* Deal with forward references to entries during gfc_resolve_code, to
4985 satisfy, at least partially, 12.5.2.5. */
4986 if (gfc_current_ns
->entries
4987 && current_entry_id
== sym
->entry_id
4990 && cs_base
->current
->op
!= EXEC_ENTRY
)
4992 gfc_entry_list
*entry
;
4993 gfc_formal_arglist
*formal
;
4995 bool seen
, saved_specification_expr
;
4997 /* If the symbol is a dummy... */
4998 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5000 entry
= gfc_current_ns
->entries
;
5003 /* ...test if the symbol is a parameter of previous entries. */
5004 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5005 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5007 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5014 /* If it has not been seen as a dummy, this is an error. */
5017 if (specification_expr
)
5018 gfc_error ("Variable %qs, used in a specification expression"
5019 ", is referenced at %L before the ENTRY statement "
5020 "in which it is a parameter",
5021 sym
->name
, &cs_base
->current
->loc
);
5023 gfc_error ("Variable %qs is used at %L before the ENTRY "
5024 "statement in which it is a parameter",
5025 sym
->name
, &cs_base
->current
->loc
);
5030 /* Now do the same check on the specification expressions. */
5031 saved_specification_expr
= specification_expr
;
5032 specification_expr
= true;
5033 if (sym
->ts
.type
== BT_CHARACTER
5034 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
5038 for (n
= 0; n
< sym
->as
->rank
; n
++)
5040 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
5042 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
5045 specification_expr
= saved_specification_expr
;
5048 /* Update the symbol's entry level. */
5049 sym
->entry_id
= current_entry_id
+ 1;
5052 /* If a symbol has been host_associated mark it. This is used latter,
5053 to identify if aliasing is possible via host association. */
5054 if (sym
->attr
.flavor
== FL_VARIABLE
5055 && gfc_current_ns
->parent
5056 && (gfc_current_ns
->parent
== sym
->ns
5057 || (gfc_current_ns
->parent
->parent
5058 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5059 sym
->attr
.host_assoc
= 1;
5062 if (t
&& !resolve_procedure_expression (e
))
5065 /* F2008, C617 and C1229. */
5066 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5067 && gfc_is_coindexed (e
))
5069 gfc_ref
*ref
, *ref2
= NULL
;
5071 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5073 if (ref
->type
== REF_COMPONENT
)
5075 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5079 for ( ; ref
; ref
= ref
->next
)
5080 if (ref
->type
== REF_COMPONENT
)
5083 /* Expression itself is not coindexed object. */
5084 if (ref
&& e
->ts
.type
== BT_CLASS
)
5086 gfc_error ("Polymorphic subobject of coindexed object at %L",
5091 /* Expression itself is coindexed object. */
5095 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5096 for ( ; c
; c
= c
->next
)
5097 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5099 gfc_error ("Coindexed object with polymorphic allocatable "
5100 "subcomponent at %L", &e
->where
);
5108 expression_rank (e
);
5110 if (t
&& flag_coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5111 add_caf_get_intrinsic (e
);
5117 /* Checks to see that the correct symbol has been host associated.
5118 The only situation where this arises is that in which a twice
5119 contained function is parsed after the host association is made.
5120 Therefore, on detecting this, change the symbol in the expression
5121 and convert the array reference into an actual arglist if the old
5122 symbol is a variable. */
5124 check_host_association (gfc_expr
*e
)
5126 gfc_symbol
*sym
, *old_sym
;
5130 gfc_actual_arglist
*arg
, *tail
= NULL
;
5131 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5133 /* If the expression is the result of substitution in
5134 interface.c(gfc_extend_expr) because there is no way in
5135 which the host association can be wrong. */
5136 if (e
->symtree
== NULL
5137 || e
->symtree
->n
.sym
== NULL
5138 || e
->user_operator
)
5141 old_sym
= e
->symtree
->n
.sym
;
5143 if (gfc_current_ns
->parent
5144 && old_sym
->ns
!= gfc_current_ns
)
5146 /* Use the 'USE' name so that renamed module symbols are
5147 correctly handled. */
5148 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5150 if (sym
&& old_sym
!= sym
5151 && sym
->ts
.type
== old_sym
->ts
.type
5152 && sym
->attr
.flavor
== FL_PROCEDURE
5153 && sym
->attr
.contained
)
5155 /* Clear the shape, since it might not be valid. */
5156 gfc_free_shape (&e
->shape
, e
->rank
);
5158 /* Give the expression the right symtree! */
5159 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5160 gcc_assert (st
!= NULL
);
5162 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5163 || e
->expr_type
== EXPR_FUNCTION
)
5165 /* Original was function so point to the new symbol, since
5166 the actual argument list is already attached to the
5168 e
->value
.function
.esym
= NULL
;
5173 /* Original was variable so convert array references into
5174 an actual arglist. This does not need any checking now
5175 since resolve_function will take care of it. */
5176 e
->value
.function
.actual
= NULL
;
5177 e
->expr_type
= EXPR_FUNCTION
;
5180 /* Ambiguity will not arise if the array reference is not
5181 the last reference. */
5182 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5183 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5186 gcc_assert (ref
->type
== REF_ARRAY
);
5188 /* Grab the start expressions from the array ref and
5189 copy them into actual arguments. */
5190 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5192 arg
= gfc_get_actual_arglist ();
5193 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5194 if (e
->value
.function
.actual
== NULL
)
5195 tail
= e
->value
.function
.actual
= arg
;
5203 /* Dump the reference list and set the rank. */
5204 gfc_free_ref_list (e
->ref
);
5206 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5209 gfc_resolve_expr (e
);
5213 /* This might have changed! */
5214 return e
->expr_type
== EXPR_FUNCTION
;
5219 gfc_resolve_character_operator (gfc_expr
*e
)
5221 gfc_expr
*op1
= e
->value
.op
.op1
;
5222 gfc_expr
*op2
= e
->value
.op
.op2
;
5223 gfc_expr
*e1
= NULL
;
5224 gfc_expr
*e2
= NULL
;
5226 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5228 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5229 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5230 else if (op1
->expr_type
== EXPR_CONSTANT
)
5231 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5232 op1
->value
.character
.length
);
5234 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5235 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5236 else if (op2
->expr_type
== EXPR_CONSTANT
)
5237 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5238 op2
->value
.character
.length
);
5240 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5250 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5251 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5252 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5253 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5254 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5260 /* Ensure that an character expression has a charlen and, if possible, a
5261 length expression. */
5264 fixup_charlen (gfc_expr
*e
)
5266 /* The cases fall through so that changes in expression type and the need
5267 for multiple fixes are picked up. In all circumstances, a charlen should
5268 be available for the middle end to hang a backend_decl on. */
5269 switch (e
->expr_type
)
5272 gfc_resolve_character_operator (e
);
5275 if (e
->expr_type
== EXPR_ARRAY
)
5276 gfc_resolve_character_array_constructor (e
);
5278 case EXPR_SUBSTRING
:
5279 if (!e
->ts
.u
.cl
&& e
->ref
)
5280 gfc_resolve_substring_charlen (e
);
5284 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5291 /* Update an actual argument to include the passed-object for type-bound
5292 procedures at the right position. */
5294 static gfc_actual_arglist
*
5295 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5298 gcc_assert (argpos
> 0);
5302 gfc_actual_arglist
* result
;
5304 result
= gfc_get_actual_arglist ();
5308 result
->name
= name
;
5314 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5316 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5321 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5324 extract_compcall_passed_object (gfc_expr
* e
)
5328 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5330 if (e
->value
.compcall
.base_object
)
5331 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5334 po
= gfc_get_expr ();
5335 po
->expr_type
= EXPR_VARIABLE
;
5336 po
->symtree
= e
->symtree
;
5337 po
->ref
= gfc_copy_ref (e
->ref
);
5338 po
->where
= e
->where
;
5341 if (!gfc_resolve_expr (po
))
5348 /* Update the arglist of an EXPR_COMPCALL expression to include the
5352 update_compcall_arglist (gfc_expr
* e
)
5355 gfc_typebound_proc
* tbp
;
5357 tbp
= e
->value
.compcall
.tbp
;
5362 po
= extract_compcall_passed_object (e
);
5366 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5372 gcc_assert (tbp
->pass_arg_num
> 0);
5373 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5381 /* Extract the passed object from a PPC call (a copy of it). */
5384 extract_ppc_passed_object (gfc_expr
*e
)
5389 po
= gfc_get_expr ();
5390 po
->expr_type
= EXPR_VARIABLE
;
5391 po
->symtree
= e
->symtree
;
5392 po
->ref
= gfc_copy_ref (e
->ref
);
5393 po
->where
= e
->where
;
5395 /* Remove PPC reference. */
5397 while ((*ref
)->next
)
5398 ref
= &(*ref
)->next
;
5399 gfc_free_ref_list (*ref
);
5402 if (!gfc_resolve_expr (po
))
5409 /* Update the actual arglist of a procedure pointer component to include the
5413 update_ppc_arglist (gfc_expr
* e
)
5417 gfc_typebound_proc
* tb
;
5419 ppc
= gfc_get_proc_ptr_comp (e
);
5427 else if (tb
->nopass
)
5430 po
= extract_ppc_passed_object (e
);
5437 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5442 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5444 gfc_error ("Base object for procedure-pointer component call at %L is of"
5445 " ABSTRACT type %qs", &e
->where
, po
->ts
.u
.derived
->name
);
5449 gcc_assert (tb
->pass_arg_num
> 0);
5450 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5458 /* Check that the object a TBP is called on is valid, i.e. it must not be
5459 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5462 check_typebound_baseobject (gfc_expr
* e
)
5465 bool return_value
= false;
5467 base
= extract_compcall_passed_object (e
);
5471 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5473 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5477 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5479 gfc_error ("Base object for type-bound procedure call at %L is of"
5480 " ABSTRACT type %qs", &e
->where
, base
->ts
.u
.derived
->name
);
5484 /* F08:C1230. If the procedure called is NOPASS,
5485 the base object must be scalar. */
5486 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5488 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5489 " be scalar", &e
->where
);
5493 return_value
= true;
5496 gfc_free_expr (base
);
5497 return return_value
;
5501 /* Resolve a call to a type-bound procedure, either function or subroutine,
5502 statically from the data in an EXPR_COMPCALL expression. The adapted
5503 arglist and the target-procedure symtree are returned. */
5506 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5507 gfc_actual_arglist
** actual
)
5509 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5510 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5512 /* Update the actual arglist for PASS. */
5513 if (!update_compcall_arglist (e
))
5516 *actual
= e
->value
.compcall
.actual
;
5517 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5519 gfc_free_ref_list (e
->ref
);
5521 e
->value
.compcall
.actual
= NULL
;
5523 /* If we find a deferred typebound procedure, check for derived types
5524 that an overriding typebound procedure has not been missed. */
5525 if (e
->value
.compcall
.name
5526 && !e
->value
.compcall
.tbp
->non_overridable
5527 && e
->value
.compcall
.base_object
5528 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5531 gfc_symbol
*derived
;
5533 /* Use the derived type of the base_object. */
5534 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5537 /* If necessary, go through the inheritance chain. */
5538 while (!st
&& derived
)
5540 /* Look for the typebound procedure 'name'. */
5541 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5542 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5543 e
->value
.compcall
.name
);
5545 derived
= gfc_get_derived_super_type (derived
);
5548 /* Now find the specific name in the derived type namespace. */
5549 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5550 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5551 derived
->ns
, 1, &st
);
5559 /* Get the ultimate declared type from an expression. In addition,
5560 return the last class/derived type reference and the copy of the
5561 reference list. If check_types is set true, derived types are
5562 identified as well as class references. */
5564 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5565 gfc_expr
*e
, bool check_types
)
5567 gfc_symbol
*declared
;
5574 *new_ref
= gfc_copy_ref (e
->ref
);
5576 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5578 if (ref
->type
!= REF_COMPONENT
)
5581 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5582 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5583 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5585 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5591 if (declared
== NULL
)
5592 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5598 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5599 which of the specific bindings (if any) matches the arglist and transform
5600 the expression into a call of that binding. */
5603 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5605 gfc_typebound_proc
* genproc
;
5606 const char* genname
;
5608 gfc_symbol
*derived
;
5610 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5611 genname
= e
->value
.compcall
.name
;
5612 genproc
= e
->value
.compcall
.tbp
;
5614 if (!genproc
->is_generic
)
5617 /* Try the bindings on this type and in the inheritance hierarchy. */
5618 for (; genproc
; genproc
= genproc
->overridden
)
5622 gcc_assert (genproc
->is_generic
);
5623 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5626 gfc_actual_arglist
* args
;
5629 gcc_assert (g
->specific
);
5631 if (g
->specific
->error
)
5634 target
= g
->specific
->u
.specific
->n
.sym
;
5636 /* Get the right arglist by handling PASS/NOPASS. */
5637 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5638 if (!g
->specific
->nopass
)
5641 po
= extract_compcall_passed_object (e
);
5644 gfc_free_actual_arglist (args
);
5648 gcc_assert (g
->specific
->pass_arg_num
> 0);
5649 gcc_assert (!g
->specific
->error
);
5650 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5651 g
->specific
->pass_arg
);
5653 resolve_actual_arglist (args
, target
->attr
.proc
,
5654 is_external_proc (target
)
5655 && gfc_sym_get_dummy_args (target
) == NULL
);
5657 /* Check if this arglist matches the formal. */
5658 matches
= gfc_arglist_matches_symbol (&args
, target
);
5660 /* Clean up and break out of the loop if we've found it. */
5661 gfc_free_actual_arglist (args
);
5664 e
->value
.compcall
.tbp
= g
->specific
;
5665 genname
= g
->specific_st
->name
;
5666 /* Pass along the name for CLASS methods, where the vtab
5667 procedure pointer component has to be referenced. */
5675 /* Nothing matching found! */
5676 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5677 " %qs at %L", genname
, &e
->where
);
5681 /* Make sure that we have the right specific instance for the name. */
5682 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5684 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5686 e
->value
.compcall
.tbp
= st
->n
.tb
;
5692 /* Resolve a call to a type-bound subroutine. */
5695 resolve_typebound_call (gfc_code
* c
, const char **name
, bool *overridable
)
5697 gfc_actual_arglist
* newactual
;
5698 gfc_symtree
* target
;
5700 /* Check that's really a SUBROUTINE. */
5701 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5703 gfc_error ("%qs at %L should be a SUBROUTINE",
5704 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5708 if (!check_typebound_baseobject (c
->expr1
))
5711 /* Pass along the name for CLASS methods, where the vtab
5712 procedure pointer component has to be referenced. */
5714 *name
= c
->expr1
->value
.compcall
.name
;
5716 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5719 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */
5721 *overridable
= !c
->expr1
->value
.compcall
.tbp
->non_overridable
;
5723 /* Transform into an ordinary EXEC_CALL for now. */
5725 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5728 c
->ext
.actual
= newactual
;
5729 c
->symtree
= target
;
5730 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5732 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5734 gfc_free_expr (c
->expr1
);
5735 c
->expr1
= gfc_get_expr ();
5736 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5737 c
->expr1
->symtree
= target
;
5738 c
->expr1
->where
= c
->loc
;
5740 return resolve_call (c
);
5744 /* Resolve a component-call expression. */
5746 resolve_compcall (gfc_expr
* e
, const char **name
)
5748 gfc_actual_arglist
* newactual
;
5749 gfc_symtree
* target
;
5751 /* Check that's really a FUNCTION. */
5752 if (!e
->value
.compcall
.tbp
->function
)
5754 gfc_error ("%qs at %L should be a FUNCTION",
5755 e
->value
.compcall
.name
, &e
->where
);
5759 /* These must not be assign-calls! */
5760 gcc_assert (!e
->value
.compcall
.assign
);
5762 if (!check_typebound_baseobject (e
))
5765 /* Pass along the name for CLASS methods, where the vtab
5766 procedure pointer component has to be referenced. */
5768 *name
= e
->value
.compcall
.name
;
5770 if (!resolve_typebound_generic_call (e
, name
))
5772 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5774 /* Take the rank from the function's symbol. */
5775 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5776 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5778 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5779 arglist to the TBP's binding target. */
5781 if (!resolve_typebound_static (e
, &target
, &newactual
))
5784 e
->value
.function
.actual
= newactual
;
5785 e
->value
.function
.name
= NULL
;
5786 e
->value
.function
.esym
= target
->n
.sym
;
5787 e
->value
.function
.isym
= NULL
;
5788 e
->symtree
= target
;
5789 e
->ts
= target
->n
.sym
->ts
;
5790 e
->expr_type
= EXPR_FUNCTION
;
5792 /* Resolution is not necessary if this is a class subroutine; this
5793 function only has to identify the specific proc. Resolution of
5794 the call will be done next in resolve_typebound_call. */
5795 return gfc_resolve_expr (e
);
5799 static bool resolve_fl_derived (gfc_symbol
*sym
);
5802 /* Resolve a typebound function, or 'method'. First separate all
5803 the non-CLASS references by calling resolve_compcall directly. */
5806 resolve_typebound_function (gfc_expr
* e
)
5808 gfc_symbol
*declared
;
5820 /* Deal with typebound operators for CLASS objects. */
5821 expr
= e
->value
.compcall
.base_object
;
5822 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5823 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5825 /* If the base_object is not a variable, the corresponding actual
5826 argument expression must be stored in e->base_expression so
5827 that the corresponding tree temporary can be used as the base
5828 object in gfc_conv_procedure_call. */
5829 if (expr
->expr_type
!= EXPR_VARIABLE
)
5831 gfc_actual_arglist
*args
;
5833 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5835 if (expr
== args
->expr
)
5840 /* Since the typebound operators are generic, we have to ensure
5841 that any delays in resolution are corrected and that the vtab
5844 declared
= ts
.u
.derived
;
5845 c
= gfc_find_component (declared
, "_vptr", true, true);
5846 if (c
->ts
.u
.derived
== NULL
)
5847 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5849 if (!resolve_compcall (e
, &name
))
5852 /* Use the generic name if it is there. */
5853 name
= name
? name
: e
->value
.function
.esym
->name
;
5854 e
->symtree
= expr
->symtree
;
5855 e
->ref
= gfc_copy_ref (expr
->ref
);
5856 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5858 /* Trim away the extraneous references that emerge from nested
5859 use of interface.c (extend_expr). */
5860 if (class_ref
&& class_ref
->next
)
5862 gfc_free_ref_list (class_ref
->next
);
5863 class_ref
->next
= NULL
;
5865 else if (e
->ref
&& !class_ref
)
5867 gfc_free_ref_list (e
->ref
);
5871 gfc_add_vptr_component (e
);
5872 gfc_add_component_ref (e
, name
);
5873 e
->value
.function
.esym
= NULL
;
5874 if (expr
->expr_type
!= EXPR_VARIABLE
)
5875 e
->base_expr
= expr
;
5880 return resolve_compcall (e
, NULL
);
5882 if (!resolve_ref (e
))
5885 /* Get the CLASS declared type. */
5886 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5888 if (!resolve_fl_derived (declared
))
5891 /* Weed out cases of the ultimate component being a derived type. */
5892 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5893 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5895 gfc_free_ref_list (new_ref
);
5896 return resolve_compcall (e
, NULL
);
5899 c
= gfc_find_component (declared
, "_data", true, true);
5900 declared
= c
->ts
.u
.derived
;
5902 /* Treat the call as if it is a typebound procedure, in order to roll
5903 out the correct name for the specific function. */
5904 if (!resolve_compcall (e
, &name
))
5906 gfc_free_ref_list (new_ref
);
5913 /* Convert the expression to a procedure pointer component call. */
5914 e
->value
.function
.esym
= NULL
;
5920 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5921 gfc_add_vptr_component (e
);
5922 gfc_add_component_ref (e
, name
);
5924 /* Recover the typespec for the expression. This is really only
5925 necessary for generic procedures, where the additional call
5926 to gfc_add_component_ref seems to throw the collection of the
5927 correct typespec. */
5931 gfc_free_ref_list (new_ref
);
5936 /* Resolve a typebound subroutine, or 'method'. First separate all
5937 the non-CLASS references by calling resolve_typebound_call
5941 resolve_typebound_subroutine (gfc_code
*code
)
5943 gfc_symbol
*declared
;
5953 st
= code
->expr1
->symtree
;
5955 /* Deal with typebound operators for CLASS objects. */
5956 expr
= code
->expr1
->value
.compcall
.base_object
;
5957 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5958 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5960 /* If the base_object is not a variable, the corresponding actual
5961 argument expression must be stored in e->base_expression so
5962 that the corresponding tree temporary can be used as the base
5963 object in gfc_conv_procedure_call. */
5964 if (expr
->expr_type
!= EXPR_VARIABLE
)
5966 gfc_actual_arglist
*args
;
5968 args
= code
->expr1
->value
.function
.actual
;
5969 for (; args
; args
= args
->next
)
5970 if (expr
== args
->expr
)
5974 /* Since the typebound operators are generic, we have to ensure
5975 that any delays in resolution are corrected and that the vtab
5977 declared
= expr
->ts
.u
.derived
;
5978 c
= gfc_find_component (declared
, "_vptr", true, true);
5979 if (c
->ts
.u
.derived
== NULL
)
5980 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5982 if (!resolve_typebound_call (code
, &name
, NULL
))
5985 /* Use the generic name if it is there. */
5986 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5987 code
->expr1
->symtree
= expr
->symtree
;
5988 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5990 /* Trim away the extraneous references that emerge from nested
5991 use of interface.c (extend_expr). */
5992 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5993 if (class_ref
&& class_ref
->next
)
5995 gfc_free_ref_list (class_ref
->next
);
5996 class_ref
->next
= NULL
;
5998 else if (code
->expr1
->ref
&& !class_ref
)
6000 gfc_free_ref_list (code
->expr1
->ref
);
6001 code
->expr1
->ref
= NULL
;
6004 /* Now use the procedure in the vtable. */
6005 gfc_add_vptr_component (code
->expr1
);
6006 gfc_add_component_ref (code
->expr1
, name
);
6007 code
->expr1
->value
.function
.esym
= NULL
;
6008 if (expr
->expr_type
!= EXPR_VARIABLE
)
6009 code
->expr1
->base_expr
= expr
;
6014 return resolve_typebound_call (code
, NULL
, NULL
);
6016 if (!resolve_ref (code
->expr1
))
6019 /* Get the CLASS declared type. */
6020 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6022 /* Weed out cases of the ultimate component being a derived type. */
6023 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6024 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6026 gfc_free_ref_list (new_ref
);
6027 return resolve_typebound_call (code
, NULL
, NULL
);
6030 if (!resolve_typebound_call (code
, &name
, &overridable
))
6032 gfc_free_ref_list (new_ref
);
6035 ts
= code
->expr1
->ts
;
6039 /* Convert the expression to a procedure pointer component call. */
6040 code
->expr1
->value
.function
.esym
= NULL
;
6041 code
->expr1
->symtree
= st
;
6044 code
->expr1
->ref
= new_ref
;
6046 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6047 gfc_add_vptr_component (code
->expr1
);
6048 gfc_add_component_ref (code
->expr1
, name
);
6050 /* Recover the typespec for the expression. This is really only
6051 necessary for generic procedures, where the additional call
6052 to gfc_add_component_ref seems to throw the collection of the
6053 correct typespec. */
6054 code
->expr1
->ts
= ts
;
6057 gfc_free_ref_list (new_ref
);
6063 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6066 resolve_ppc_call (gfc_code
* c
)
6068 gfc_component
*comp
;
6070 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6071 gcc_assert (comp
!= NULL
);
6073 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6074 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6076 if (!comp
->attr
.subroutine
)
6077 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6079 if (!resolve_ref (c
->expr1
))
6082 if (!update_ppc_arglist (c
->expr1
))
6085 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6087 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6088 !(comp
->ts
.interface
6089 && comp
->ts
.interface
->formal
)))
6092 if (!pure_subroutine (comp
->ts
.interface
, comp
->name
, &c
->expr1
->where
))
6095 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6101 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6104 resolve_expr_ppc (gfc_expr
* e
)
6106 gfc_component
*comp
;
6108 comp
= gfc_get_proc_ptr_comp (e
);
6109 gcc_assert (comp
!= NULL
);
6111 /* Convert to EXPR_FUNCTION. */
6112 e
->expr_type
= EXPR_FUNCTION
;
6113 e
->value
.function
.isym
= NULL
;
6114 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6116 if (comp
->as
!= NULL
)
6117 e
->rank
= comp
->as
->rank
;
6119 if (!comp
->attr
.function
)
6120 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6122 if (!resolve_ref (e
))
6125 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6126 !(comp
->ts
.interface
6127 && comp
->ts
.interface
->formal
)))
6130 if (!update_ppc_arglist (e
))
6133 if (!check_pure_function(e
))
6136 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6143 gfc_is_expandable_expr (gfc_expr
*e
)
6145 gfc_constructor
*con
;
6147 if (e
->expr_type
== EXPR_ARRAY
)
6149 /* Traverse the constructor looking for variables that are flavor
6150 parameter. Parameters must be expanded since they are fully used at
6152 con
= gfc_constructor_first (e
->value
.constructor
);
6153 for (; con
; con
= gfc_constructor_next (con
))
6155 if (con
->expr
->expr_type
== EXPR_VARIABLE
6156 && con
->expr
->symtree
6157 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6158 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6160 if (con
->expr
->expr_type
== EXPR_ARRAY
6161 && gfc_is_expandable_expr (con
->expr
))
6169 /* Resolve an expression. That is, make sure that types of operands agree
6170 with their operators, intrinsic operators are converted to function calls
6171 for overloaded types and unresolved function references are resolved. */
6174 gfc_resolve_expr (gfc_expr
*e
)
6177 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6182 /* inquiry_argument only applies to variables. */
6183 inquiry_save
= inquiry_argument
;
6184 actual_arg_save
= actual_arg
;
6185 first_actual_arg_save
= first_actual_arg
;
6187 if (e
->expr_type
!= EXPR_VARIABLE
)
6189 inquiry_argument
= false;
6191 first_actual_arg
= false;
6194 switch (e
->expr_type
)
6197 t
= resolve_operator (e
);
6203 if (check_host_association (e
))
6204 t
= resolve_function (e
);
6206 t
= resolve_variable (e
);
6208 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6209 && e
->ref
->type
!= REF_SUBSTRING
)
6210 gfc_resolve_substring_charlen (e
);
6215 t
= resolve_typebound_function (e
);
6218 case EXPR_SUBSTRING
:
6219 t
= resolve_ref (e
);
6228 t
= resolve_expr_ppc (e
);
6233 if (!resolve_ref (e
))
6236 t
= gfc_resolve_array_constructor (e
);
6237 /* Also try to expand a constructor. */
6240 expression_rank (e
);
6241 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6242 gfc_expand_constructor (e
, false);
6245 /* This provides the opportunity for the length of constructors with
6246 character valued function elements to propagate the string length
6247 to the expression. */
6248 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6250 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6251 here rather then add a duplicate test for it above. */
6252 gfc_expand_constructor (e
, false);
6253 t
= gfc_resolve_character_array_constructor (e
);
6258 case EXPR_STRUCTURE
:
6259 t
= resolve_ref (e
);
6263 t
= resolve_structure_cons (e
, 0);
6267 t
= gfc_simplify_expr (e
, 0);
6271 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6274 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6277 inquiry_argument
= inquiry_save
;
6278 actual_arg
= actual_arg_save
;
6279 first_actual_arg
= first_actual_arg_save
;
6285 /* Resolve an expression from an iterator. They must be scalar and have
6286 INTEGER or (optionally) REAL type. */
6289 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6290 const char *name_msgid
)
6292 if (!gfc_resolve_expr (expr
))
6295 if (expr
->rank
!= 0)
6297 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6301 if (expr
->ts
.type
!= BT_INTEGER
)
6303 if (expr
->ts
.type
== BT_REAL
)
6306 return gfc_notify_std (GFC_STD_F95_DEL
,
6307 "%s at %L must be integer",
6308 _(name_msgid
), &expr
->where
);
6311 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6318 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6326 /* Resolve the expressions in an iterator structure. If REAL_OK is
6327 false allow only INTEGER type iterators, otherwise allow REAL types.
6328 Set own_scope to true for ac-implied-do and data-implied-do as those
6329 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6332 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6334 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6337 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6338 _("iterator variable")))
6341 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6342 "Start expression in DO loop"))
6345 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6346 "End expression in DO loop"))
6349 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6350 "Step expression in DO loop"))
6353 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6355 if ((iter
->step
->ts
.type
== BT_INTEGER
6356 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6357 || (iter
->step
->ts
.type
== BT_REAL
6358 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6360 gfc_error ("Step expression in DO loop at %L cannot be zero",
6361 &iter
->step
->where
);
6366 /* Convert start, end, and step to the same type as var. */
6367 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6368 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6369 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6371 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6372 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6373 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6375 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6376 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6377 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6379 if (iter
->start
->expr_type
== EXPR_CONSTANT
6380 && iter
->end
->expr_type
== EXPR_CONSTANT
6381 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6384 if (iter
->start
->ts
.type
== BT_INTEGER
)
6386 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6387 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6391 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6392 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6394 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6395 gfc_warning (OPT_Wzerotrip
,
6396 "DO loop at %L will be executed zero times",
6397 &iter
->step
->where
);
6404 /* Traversal function for find_forall_index. f == 2 signals that
6405 that variable itself is not to be checked - only the references. */
6408 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6410 if (expr
->expr_type
!= EXPR_VARIABLE
)
6413 /* A scalar assignment */
6414 if (!expr
->ref
|| *f
== 1)
6416 if (expr
->symtree
->n
.sym
== sym
)
6428 /* Check whether the FORALL index appears in the expression or not.
6429 Returns true if SYM is found in EXPR. */
6432 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6434 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6441 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6442 to be a scalar INTEGER variable. The subscripts and stride are scalar
6443 INTEGERs, and if stride is a constant it must be nonzero.
6444 Furthermore "A subscript or stride in a forall-triplet-spec shall
6445 not contain a reference to any index-name in the
6446 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6449 resolve_forall_iterators (gfc_forall_iterator
*it
)
6451 gfc_forall_iterator
*iter
, *iter2
;
6453 for (iter
= it
; iter
; iter
= iter
->next
)
6455 if (gfc_resolve_expr (iter
->var
)
6456 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6457 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6460 if (gfc_resolve_expr (iter
->start
)
6461 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6462 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6463 &iter
->start
->where
);
6464 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6465 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6467 if (gfc_resolve_expr (iter
->end
)
6468 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6469 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6471 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6472 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6474 if (gfc_resolve_expr (iter
->stride
))
6476 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6477 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6478 &iter
->stride
->where
, "INTEGER");
6480 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6481 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6482 gfc_error ("FORALL stride expression at %L cannot be zero",
6483 &iter
->stride
->where
);
6485 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6486 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6489 for (iter
= it
; iter
; iter
= iter
->next
)
6490 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6492 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6493 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6494 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6495 gfc_error ("FORALL index %qs may not appear in triplet "
6496 "specification at %L", iter
->var
->symtree
->name
,
6497 &iter2
->start
->where
);
6502 /* Given a pointer to a symbol that is a derived type, see if it's
6503 inaccessible, i.e. if it's defined in another module and the components are
6504 PRIVATE. The search is recursive if necessary. Returns zero if no
6505 inaccessible components are found, nonzero otherwise. */
6508 derived_inaccessible (gfc_symbol
*sym
)
6512 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6515 for (c
= sym
->components
; c
; c
= c
->next
)
6517 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6525 /* Resolve the argument of a deallocate expression. The expression must be
6526 a pointer or a full array. */
6529 resolve_deallocate_expr (gfc_expr
*e
)
6531 symbol_attribute attr
;
6532 int allocatable
, pointer
;
6538 if (!gfc_resolve_expr (e
))
6541 if (e
->expr_type
!= EXPR_VARIABLE
)
6544 sym
= e
->symtree
->n
.sym
;
6545 unlimited
= UNLIMITED_POLY(sym
);
6547 if (sym
->ts
.type
== BT_CLASS
)
6549 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6550 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6554 allocatable
= sym
->attr
.allocatable
;
6555 pointer
= sym
->attr
.pointer
;
6557 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6562 if (ref
->u
.ar
.type
!= AR_FULL
6563 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6564 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6569 c
= ref
->u
.c
.component
;
6570 if (c
->ts
.type
== BT_CLASS
)
6572 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6573 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6577 allocatable
= c
->attr
.allocatable
;
6578 pointer
= c
->attr
.pointer
;
6588 attr
= gfc_expr_attr (e
);
6590 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6593 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6599 if (gfc_is_coindexed (e
))
6601 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6606 && !gfc_check_vardef_context (e
, true, true, false,
6607 _("DEALLOCATE object")))
6609 if (!gfc_check_vardef_context (e
, false, true, false,
6610 _("DEALLOCATE object")))
6617 /* Returns true if the expression e contains a reference to the symbol sym. */
6619 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6621 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6628 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6630 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6634 /* Given the expression node e for an allocatable/pointer of derived type to be
6635 allocated, get the expression node to be initialized afterwards (needed for
6636 derived types with default initializers, and derived types with allocatable
6637 components that need nullification.) */
6640 gfc_expr_to_initialize (gfc_expr
*e
)
6646 result
= gfc_copy_expr (e
);
6648 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6649 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6650 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6652 ref
->u
.ar
.type
= AR_FULL
;
6654 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6655 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6660 gfc_free_shape (&result
->shape
, result
->rank
);
6662 /* Recalculate rank, shape, etc. */
6663 gfc_resolve_expr (result
);
6668 /* If the last ref of an expression is an array ref, return a copy of the
6669 expression with that one removed. Otherwise, a copy of the original
6670 expression. This is used for allocate-expressions and pointer assignment
6671 LHS, where there may be an array specification that needs to be stripped
6672 off when using gfc_check_vardef_context. */
6675 remove_last_array_ref (gfc_expr
* e
)
6680 e2
= gfc_copy_expr (e
);
6681 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6682 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6684 gfc_free_ref_list (*r
);
6693 /* Used in resolve_allocate_expr to check that a allocation-object and
6694 a source-expr are conformable. This does not catch all possible
6695 cases; in particular a runtime checking is needed. */
6698 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6701 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6703 /* First compare rank. */
6704 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6705 || (!tail
&& e1
->rank
!= e2
->rank
))
6707 gfc_error ("Source-expr at %L must be scalar or have the "
6708 "same rank as the allocate-object at %L",
6709 &e1
->where
, &e2
->where
);
6720 for (i
= 0; i
< e1
->rank
; i
++)
6722 if (tail
->u
.ar
.start
[i
] == NULL
)
6725 if (tail
->u
.ar
.end
[i
])
6727 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6728 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6729 mpz_add_ui (s
, s
, 1);
6733 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6736 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6738 gfc_error_1 ("Source-expr at %L and allocate-object at %L must "
6739 "have the same shape", &e1
->where
, &e2
->where
);
6752 /* Resolve the expression in an ALLOCATE statement, doing the additional
6753 checks to see whether the expression is OK or not. The expression must
6754 have a trailing array reference that gives the size of the array. */
6757 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6759 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6763 symbol_attribute attr
;
6764 gfc_ref
*ref
, *ref2
;
6767 gfc_symbol
*sym
= NULL
;
6772 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6773 checking of coarrays. */
6774 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6775 if (ref
->next
== NULL
)
6778 if (ref
&& ref
->type
== REF_ARRAY
)
6779 ref
->u
.ar
.in_allocate
= true;
6781 if (!gfc_resolve_expr (e
))
6784 /* Make sure the expression is allocatable or a pointer. If it is
6785 pointer, the next-to-last reference must be a pointer. */
6789 sym
= e
->symtree
->n
.sym
;
6791 /* Check whether ultimate component is abstract and CLASS. */
6794 /* Is the allocate-object unlimited polymorphic? */
6795 unlimited
= UNLIMITED_POLY(e
);
6797 if (e
->expr_type
!= EXPR_VARIABLE
)
6800 attr
= gfc_expr_attr (e
);
6801 pointer
= attr
.pointer
;
6802 dimension
= attr
.dimension
;
6803 codimension
= attr
.codimension
;
6807 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6809 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6810 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6811 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6812 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6813 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6817 allocatable
= sym
->attr
.allocatable
;
6818 pointer
= sym
->attr
.pointer
;
6819 dimension
= sym
->attr
.dimension
;
6820 codimension
= sym
->attr
.codimension
;
6825 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6830 if (ref
->u
.ar
.codimen
> 0)
6833 for (n
= ref
->u
.ar
.dimen
;
6834 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6835 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6842 if (ref
->next
!= NULL
)
6850 gfc_error ("Coindexed allocatable object at %L",
6855 c
= ref
->u
.c
.component
;
6856 if (c
->ts
.type
== BT_CLASS
)
6858 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6859 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6860 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6861 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6862 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6866 allocatable
= c
->attr
.allocatable
;
6867 pointer
= c
->attr
.pointer
;
6868 dimension
= c
->attr
.dimension
;
6869 codimension
= c
->attr
.codimension
;
6870 is_abstract
= c
->attr
.abstract
;
6882 /* Check for F08:C628. */
6883 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6885 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6890 /* Some checks for the SOURCE tag. */
6893 /* Check F03:C631. */
6894 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6896 gfc_error_1 ("Type of entity at %L is type incompatible with "
6897 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6901 /* Check F03:C632 and restriction following Note 6.18. */
6902 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6905 /* Check F03:C633. */
6906 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6908 gfc_error_1 ("The allocate-object at %L and the source-expr at %L "
6909 "shall have the same kind type parameter",
6910 &e
->where
, &code
->expr3
->where
);
6914 /* Check F2008, C642. */
6915 if (code
->expr3
->ts
.type
== BT_DERIVED
6916 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6917 || (code
->expr3
->ts
.u
.derived
->from_intmod
6918 == INTMOD_ISO_FORTRAN_ENV
6919 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6920 == ISOFORTRAN_LOCK_TYPE
)))
6922 gfc_error_1 ("The source-expr at %L shall neither be of type "
6923 "LOCK_TYPE nor have a LOCK_TYPE component if "
6924 "allocate-object at %L is a coarray",
6925 &code
->expr3
->where
, &e
->where
);
6930 /* Check F08:C629. */
6931 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6934 gcc_assert (e
->ts
.type
== BT_CLASS
);
6935 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6936 "type-spec or source-expr", sym
->name
, &e
->where
);
6940 /* Check F08:C632. */
6941 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
6942 && !UNLIMITED_POLY (e
))
6944 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6945 code
->ext
.alloc
.ts
.u
.cl
->length
);
6946 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6948 gfc_error ("Allocating %s at %L with type-spec requires the same "
6949 "character-length parameter as in the declaration",
6950 sym
->name
, &e
->where
);
6955 /* In the variable definition context checks, gfc_expr_attr is used
6956 on the expression. This is fooled by the array specification
6957 present in e, thus we have to eliminate that one temporarily. */
6958 e2
= remove_last_array_ref (e
);
6961 t
= gfc_check_vardef_context (e2
, true, true, false,
6962 _("ALLOCATE object"));
6964 t
= gfc_check_vardef_context (e2
, false, true, false,
6965 _("ALLOCATE object"));
6970 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6971 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6973 /* For class arrays, the initialization with SOURCE is done
6974 using _copy and trans_call. It is convenient to exploit that
6975 when the allocated type is different from the declared type but
6976 no SOURCE exists by setting expr3. */
6977 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6979 else if (!code
->expr3
)
6981 /* Set up default initializer if needed. */
6985 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6986 ts
= code
->ext
.alloc
.ts
;
6990 if (ts
.type
== BT_CLASS
)
6991 ts
= ts
.u
.derived
->components
->ts
;
6993 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6995 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6996 init_st
->loc
= code
->loc
;
6997 init_st
->expr1
= gfc_expr_to_initialize (e
);
6998 init_st
->expr2
= init_e
;
6999 init_st
->next
= code
->next
;
7000 code
->next
= init_st
;
7003 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7005 /* Default initialization via MOLD (non-polymorphic). */
7006 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7009 gfc_resolve_expr (rhs
);
7010 gfc_free_expr (code
->expr3
);
7015 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7017 /* Make sure the vtab symbol is present when
7018 the module variables are generated. */
7019 gfc_typespec ts
= e
->ts
;
7021 ts
= code
->expr3
->ts
;
7022 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7023 ts
= code
->ext
.alloc
.ts
;
7025 gfc_find_derived_vtab (ts
.u
.derived
);
7028 e
= gfc_expr_to_initialize (e
);
7030 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7032 /* Again, make sure the vtab symbol is present when
7033 the module variables are generated. */
7034 gfc_typespec
*ts
= NULL
;
7036 ts
= &code
->expr3
->ts
;
7038 ts
= &code
->ext
.alloc
.ts
;
7045 e
= gfc_expr_to_initialize (e
);
7048 if (dimension
== 0 && codimension
== 0)
7051 /* Make sure the last reference node is an array specification. */
7053 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7054 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7056 gfc_error ("Array specification required in ALLOCATE statement "
7057 "at %L", &e
->where
);
7061 /* Make sure that the array section reference makes sense in the
7062 context of an ALLOCATE specification. */
7067 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7068 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7070 gfc_error ("Coarray specification required in ALLOCATE statement "
7071 "at %L", &e
->where
);
7075 for (i
= 0; i
< ar
->dimen
; i
++)
7077 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7080 switch (ar
->dimen_type
[i
])
7086 if (ar
->start
[i
] != NULL
7087 && ar
->end
[i
] != NULL
7088 && ar
->stride
[i
] == NULL
)
7091 /* Fall Through... */
7096 case DIMEN_THIS_IMAGE
:
7097 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7103 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7105 sym
= a
->expr
->symtree
->n
.sym
;
7107 /* TODO - check derived type components. */
7108 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7111 if ((ar
->start
[i
] != NULL
7112 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7113 || (ar
->end
[i
] != NULL
7114 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7116 gfc_error ("%qs must not appear in the array specification at "
7117 "%L in the same ALLOCATE statement where it is "
7118 "itself allocated", sym
->name
, &ar
->where
);
7124 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7126 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7127 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7129 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7131 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7132 "statement at %L", &e
->where
);
7138 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7139 && ar
->stride
[i
] == NULL
)
7142 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7155 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7157 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7158 gfc_alloc
*a
, *p
, *q
;
7161 errmsg
= code
->expr2
;
7163 /* Check the stat variable. */
7166 gfc_check_vardef_context (stat
, false, false, false,
7167 _("STAT variable"));
7169 if ((stat
->ts
.type
!= BT_INTEGER
7170 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7171 || stat
->ref
->type
== REF_COMPONENT
)))
7173 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7174 "variable", &stat
->where
);
7176 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7177 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7179 gfc_ref
*ref1
, *ref2
;
7182 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7183 ref1
= ref1
->next
, ref2
= ref2
->next
)
7185 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7187 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7196 gfc_error ("Stat-variable at %L shall not be %sd within "
7197 "the same %s statement", &stat
->where
, fcn
, fcn
);
7203 /* Check the errmsg variable. */
7207 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
7210 gfc_check_vardef_context (errmsg
, false, false, false,
7211 _("ERRMSG variable"));
7213 if ((errmsg
->ts
.type
!= BT_CHARACTER
7215 && (errmsg
->ref
->type
== REF_ARRAY
7216 || errmsg
->ref
->type
== REF_COMPONENT
)))
7217 || errmsg
->rank
> 0 )
7218 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7219 "variable", &errmsg
->where
);
7221 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7222 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7224 gfc_ref
*ref1
, *ref2
;
7227 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7228 ref1
= ref1
->next
, ref2
= ref2
->next
)
7230 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7232 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7241 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7242 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7248 /* Check that an allocate-object appears only once in the statement. */
7250 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7253 for (q
= p
->next
; q
; q
= q
->next
)
7256 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7258 /* This is a potential collision. */
7259 gfc_ref
*pr
= pe
->ref
;
7260 gfc_ref
*qr
= qe
->ref
;
7262 /* Follow the references until
7263 a) They start to differ, in which case there is no error;
7264 you can deallocate a%b and a%c in a single statement
7265 b) Both of them stop, which is an error
7266 c) One of them stops, which is also an error. */
7269 if (pr
== NULL
&& qr
== NULL
)
7271 gfc_error_1 ("Allocate-object at %L also appears at %L",
7272 &pe
->where
, &qe
->where
);
7275 else if (pr
!= NULL
&& qr
== NULL
)
7277 gfc_error_1 ("Allocate-object at %L is subobject of"
7278 " object at %L", &pe
->where
, &qe
->where
);
7281 else if (pr
== NULL
&& qr
!= NULL
)
7283 gfc_error_1 ("Allocate-object at %L is subobject of"
7284 " object at %L", &qe
->where
, &pe
->where
);
7287 /* Here, pr != NULL && qr != NULL */
7288 gcc_assert(pr
->type
== qr
->type
);
7289 if (pr
->type
== REF_ARRAY
)
7291 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7293 gcc_assert (qr
->type
== REF_ARRAY
);
7295 if (pr
->next
&& qr
->next
)
7298 gfc_array_ref
*par
= &(pr
->u
.ar
);
7299 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7301 for (i
=0; i
<par
->dimen
; i
++)
7303 if ((par
->start
[i
] != NULL
7304 || qar
->start
[i
] != NULL
)
7305 && gfc_dep_compare_expr (par
->start
[i
],
7306 qar
->start
[i
]) != 0)
7313 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7326 if (strcmp (fcn
, "ALLOCATE") == 0)
7328 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7329 resolve_allocate_expr (a
->expr
, code
);
7333 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7334 resolve_deallocate_expr (a
->expr
);
7339 /************ SELECT CASE resolution subroutines ************/
7341 /* Callback function for our mergesort variant. Determines interval
7342 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7343 op1 > op2. Assumes we're not dealing with the default case.
7344 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7345 There are nine situations to check. */
7348 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7352 if (op1
->low
== NULL
) /* op1 = (:L) */
7354 /* op2 = (:N), so overlap. */
7356 /* op2 = (M:) or (M:N), L < M */
7357 if (op2
->low
!= NULL
7358 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7361 else if (op1
->high
== NULL
) /* op1 = (K:) */
7363 /* op2 = (M:), so overlap. */
7365 /* op2 = (:N) or (M:N), K > N */
7366 if (op2
->high
!= NULL
7367 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7370 else /* op1 = (K:L) */
7372 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7373 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7375 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7376 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7378 else /* op2 = (M:N) */
7382 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7385 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7394 /* Merge-sort a double linked case list, detecting overlap in the
7395 process. LIST is the head of the double linked case list before it
7396 is sorted. Returns the head of the sorted list if we don't see any
7397 overlap, or NULL otherwise. */
7400 check_case_overlap (gfc_case
*list
)
7402 gfc_case
*p
, *q
, *e
, *tail
;
7403 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7405 /* If the passed list was empty, return immediately. */
7412 /* Loop unconditionally. The only exit from this loop is a return
7413 statement, when we've finished sorting the case list. */
7420 /* Count the number of merges we do in this pass. */
7423 /* Loop while there exists a merge to be done. */
7428 /* Count this merge. */
7431 /* Cut the list in two pieces by stepping INSIZE places
7432 forward in the list, starting from P. */
7435 for (i
= 0; i
< insize
; i
++)
7444 /* Now we have two lists. Merge them! */
7445 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7447 /* See from which the next case to merge comes from. */
7450 /* P is empty so the next case must come from Q. */
7455 else if (qsize
== 0 || q
== NULL
)
7464 cmp
= compare_cases (p
, q
);
7467 /* The whole case range for P is less than the
7475 /* The whole case range for Q is greater than
7476 the case range for P. */
7483 /* The cases overlap, or they are the same
7484 element in the list. Either way, we must
7485 issue an error and get the next case from P. */
7486 /* FIXME: Sort P and Q by line number. */
7487 gfc_error_1 ("CASE label at %L overlaps with CASE "
7488 "label at %L", &p
->where
, &q
->where
);
7496 /* Add the next element to the merged list. */
7505 /* P has now stepped INSIZE places along, and so has Q. So
7506 they're the same. */
7511 /* If we have done only one merge or none at all, we've
7512 finished sorting the cases. */
7521 /* Otherwise repeat, merging lists twice the size. */
7527 /* Check to see if an expression is suitable for use in a CASE statement.
7528 Makes sure that all case expressions are scalar constants of the same
7529 type. Return false if anything is wrong. */
7532 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7534 if (e
== NULL
) return true;
7536 if (e
->ts
.type
!= case_expr
->ts
.type
)
7538 gfc_error ("Expression in CASE statement at %L must be of type %s",
7539 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7543 /* C805 (R808) For a given case-construct, each case-value shall be of
7544 the same type as case-expr. For character type, length differences
7545 are allowed, but the kind type parameters shall be the same. */
7547 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7549 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7550 &e
->where
, case_expr
->ts
.kind
);
7554 /* Convert the case value kind to that of case expression kind,
7557 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7558 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7562 gfc_error ("Expression in CASE statement at %L must be scalar",
7571 /* Given a completely parsed select statement, we:
7573 - Validate all expressions and code within the SELECT.
7574 - Make sure that the selection expression is not of the wrong type.
7575 - Make sure that no case ranges overlap.
7576 - Eliminate unreachable cases and unreachable code resulting from
7577 removing case labels.
7579 The standard does allow unreachable cases, e.g. CASE (5:3). But
7580 they are a hassle for code generation, and to prevent that, we just
7581 cut them out here. This is not necessary for overlapping cases
7582 because they are illegal and we never even try to generate code.
7584 We have the additional caveat that a SELECT construct could have
7585 been a computed GOTO in the source code. Fortunately we can fairly
7586 easily work around that here: The case_expr for a "real" SELECT CASE
7587 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7588 we have to do is make sure that the case_expr is a scalar integer
7592 resolve_select (gfc_code
*code
, bool select_type
)
7595 gfc_expr
*case_expr
;
7596 gfc_case
*cp
, *default_case
, *tail
, *head
;
7597 int seen_unreachable
;
7603 if (code
->expr1
== NULL
)
7605 /* This was actually a computed GOTO statement. */
7606 case_expr
= code
->expr2
;
7607 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7608 gfc_error ("Selection expression in computed GOTO statement "
7609 "at %L must be a scalar integer expression",
7612 /* Further checking is not necessary because this SELECT was built
7613 by the compiler, so it should always be OK. Just move the
7614 case_expr from expr2 to expr so that we can handle computed
7615 GOTOs as normal SELECTs from here on. */
7616 code
->expr1
= code
->expr2
;
7621 case_expr
= code
->expr1
;
7622 type
= case_expr
->ts
.type
;
7625 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7627 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7628 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7630 /* Punt. Going on here just produce more garbage error messages. */
7635 if (!select_type
&& case_expr
->rank
!= 0)
7637 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7638 "expression", &case_expr
->where
);
7644 /* Raise a warning if an INTEGER case value exceeds the range of
7645 the case-expr. Later, all expressions will be promoted to the
7646 largest kind of all case-labels. */
7648 if (type
== BT_INTEGER
)
7649 for (body
= code
->block
; body
; body
= body
->block
)
7650 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7653 && gfc_check_integer_range (cp
->low
->value
.integer
,
7654 case_expr
->ts
.kind
) != ARITH_OK
)
7655 gfc_warning (0, "Expression in CASE statement at %L is "
7656 "not in the range of %s", &cp
->low
->where
,
7657 gfc_typename (&case_expr
->ts
));
7660 && cp
->low
!= cp
->high
7661 && gfc_check_integer_range (cp
->high
->value
.integer
,
7662 case_expr
->ts
.kind
) != ARITH_OK
)
7663 gfc_warning (0, "Expression in CASE statement at %L is "
7664 "not in the range of %s", &cp
->high
->where
,
7665 gfc_typename (&case_expr
->ts
));
7668 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7669 of the SELECT CASE expression and its CASE values. Walk the lists
7670 of case values, and if we find a mismatch, promote case_expr to
7671 the appropriate kind. */
7673 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7675 for (body
= code
->block
; body
; body
= body
->block
)
7677 /* Walk the case label list. */
7678 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7680 /* Intercept the DEFAULT case. It does not have a kind. */
7681 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7684 /* Unreachable case ranges are discarded, so ignore. */
7685 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7686 && cp
->low
!= cp
->high
7687 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7691 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7692 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7694 if (cp
->high
!= NULL
7695 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7696 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7701 /* Assume there is no DEFAULT case. */
7702 default_case
= NULL
;
7707 for (body
= code
->block
; body
; body
= body
->block
)
7709 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7711 seen_unreachable
= 0;
7713 /* Walk the case label list, making sure that all case labels
7715 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7717 /* Count the number of cases in the whole construct. */
7720 /* Intercept the DEFAULT case. */
7721 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7723 if (default_case
!= NULL
)
7725 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
7726 "by a second DEFAULT CASE at %L",
7727 &default_case
->where
, &cp
->where
);
7738 /* Deal with single value cases and case ranges. Errors are
7739 issued from the validation function. */
7740 if (!validate_case_label_expr (cp
->low
, case_expr
)
7741 || !validate_case_label_expr (cp
->high
, case_expr
))
7747 if (type
== BT_LOGICAL
7748 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7749 || cp
->low
!= cp
->high
))
7751 gfc_error ("Logical range in CASE statement at %L is not "
7752 "allowed", &cp
->low
->where
);
7757 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7760 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7761 if (value
& seen_logical
)
7763 gfc_error ("Constant logical value in CASE statement "
7764 "is repeated at %L",
7769 seen_logical
|= value
;
7772 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7773 && cp
->low
!= cp
->high
7774 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7776 if (warn_surprising
)
7777 gfc_warning (OPT_Wsurprising
,
7778 "Range specification at %L can never be matched",
7781 cp
->unreachable
= 1;
7782 seen_unreachable
= 1;
7786 /* If the case range can be matched, it can also overlap with
7787 other cases. To make sure it does not, we put it in a
7788 double linked list here. We sort that with a merge sort
7789 later on to detect any overlapping cases. */
7793 head
->right
= head
->left
= NULL
;
7798 tail
->right
->left
= tail
;
7805 /* It there was a failure in the previous case label, give up
7806 for this case label list. Continue with the next block. */
7810 /* See if any case labels that are unreachable have been seen.
7811 If so, we eliminate them. This is a bit of a kludge because
7812 the case lists for a single case statement (label) is a
7813 single forward linked lists. */
7814 if (seen_unreachable
)
7816 /* Advance until the first case in the list is reachable. */
7817 while (body
->ext
.block
.case_list
!= NULL
7818 && body
->ext
.block
.case_list
->unreachable
)
7820 gfc_case
*n
= body
->ext
.block
.case_list
;
7821 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7823 gfc_free_case_list (n
);
7826 /* Strip all other unreachable cases. */
7827 if (body
->ext
.block
.case_list
)
7829 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
7831 if (cp
->next
->unreachable
)
7833 gfc_case
*n
= cp
->next
;
7834 cp
->next
= cp
->next
->next
;
7836 gfc_free_case_list (n
);
7843 /* See if there were overlapping cases. If the check returns NULL,
7844 there was overlap. In that case we don't do anything. If head
7845 is non-NULL, we prepend the DEFAULT case. The sorted list can
7846 then used during code generation for SELECT CASE constructs with
7847 a case expression of a CHARACTER type. */
7850 head
= check_case_overlap (head
);
7852 /* Prepend the default_case if it is there. */
7853 if (head
!= NULL
&& default_case
)
7855 default_case
->left
= NULL
;
7856 default_case
->right
= head
;
7857 head
->left
= default_case
;
7861 /* Eliminate dead blocks that may be the result if we've seen
7862 unreachable case labels for a block. */
7863 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7865 if (body
->block
->ext
.block
.case_list
== NULL
)
7867 /* Cut the unreachable block from the code chain. */
7868 gfc_code
*c
= body
->block
;
7869 body
->block
= c
->block
;
7871 /* Kill the dead block, but not the blocks below it. */
7873 gfc_free_statements (c
);
7877 /* More than two cases is legal but insane for logical selects.
7878 Issue a warning for it. */
7879 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
7880 gfc_warning (OPT_Wsurprising
,
7881 "Logical SELECT CASE block at %L has more that two cases",
7886 /* Check if a derived type is extensible. */
7889 gfc_type_is_extensible (gfc_symbol
*sym
)
7891 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7892 || (sym
->attr
.is_class
7893 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7897 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7898 correct as well as possibly the array-spec. */
7901 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7905 gcc_assert (sym
->assoc
);
7906 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7908 /* If this is for SELECT TYPE, the target may not yet be set. In that
7909 case, return. Resolution will be called later manually again when
7911 target
= sym
->assoc
->target
;
7914 gcc_assert (!sym
->assoc
->dangling
);
7916 if (resolve_target
&& !gfc_resolve_expr (target
))
7919 /* For variable targets, we get some attributes from the target. */
7920 if (target
->expr_type
== EXPR_VARIABLE
)
7924 gcc_assert (target
->symtree
);
7925 tsym
= target
->symtree
->n
.sym
;
7927 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7928 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7930 sym
->attr
.target
= tsym
->attr
.target
7931 || gfc_expr_attr (target
).pointer
;
7932 if (is_subref_array (target
))
7933 sym
->attr
.subref_array_pointer
= 1;
7936 /* Get type if this was not already set. Note that it can be
7937 some other type than the target in case this is a SELECT TYPE
7938 selector! So we must not update when the type is already there. */
7939 if (sym
->ts
.type
== BT_UNKNOWN
)
7940 sym
->ts
= target
->ts
;
7941 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7943 /* See if this is a valid association-to-variable. */
7944 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7945 && !gfc_has_vector_subscript (target
));
7947 /* Finally resolve if this is an array or not. */
7948 if (sym
->attr
.dimension
&& target
->rank
== 0)
7950 /* primary.c makes the assumption that a reference to an associate
7951 name followed by a left parenthesis is an array reference. */
7952 if (sym
->ts
.type
!= BT_CHARACTER
)
7953 gfc_error ("Associate-name %qs at %L is used as array",
7954 sym
->name
, &sym
->declared_at
);
7955 sym
->attr
.dimension
= 0;
7959 /* We cannot deal with class selectors that need temporaries. */
7960 if (target
->ts
.type
== BT_CLASS
7961 && gfc_ref_needs_temporary_p (target
->ref
))
7963 gfc_error ("CLASS selector at %L needs a temporary which is not "
7964 "yet implemented", &target
->where
);
7968 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7969 sym
->attr
.dimension
= 1;
7970 else if (target
->ts
.type
== BT_CLASS
)
7971 gfc_fix_class_refs (target
);
7973 /* The associate-name will have a correct type by now. Make absolutely
7974 sure that it has not picked up a dimension attribute. */
7975 if (sym
->ts
.type
== BT_CLASS
)
7976 sym
->attr
.dimension
= 0;
7978 if (sym
->attr
.dimension
)
7980 sym
->as
= gfc_get_array_spec ();
7981 sym
->as
->rank
= target
->rank
;
7982 sym
->as
->type
= AS_DEFERRED
;
7983 sym
->as
->corank
= gfc_get_corank (target
);
7986 /* Mark this as an associate variable. */
7987 sym
->attr
.associate_var
= 1;
7989 /* If the target is a good class object, so is the associate variable. */
7990 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7991 sym
->attr
.class_ok
= 1;
7995 /* Resolve a SELECT TYPE statement. */
7998 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8000 gfc_symbol
*selector_type
;
8001 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8002 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8005 char name
[GFC_MAX_SYMBOL_LEN
];
8010 ns
= code
->ext
.block
.ns
;
8013 /* Check for F03:C813. */
8014 if (code
->expr1
->ts
.type
!= BT_CLASS
8015 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8017 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8018 "at %L", &code
->loc
);
8022 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8027 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8028 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8029 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8031 /* F2008: C803 The selector expression must not be coindexed. */
8032 if (gfc_is_coindexed (code
->expr2
))
8034 gfc_error ("Selector at %L must not be coindexed",
8035 &code
->expr2
->where
);
8042 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8044 if (gfc_is_coindexed (code
->expr1
))
8046 gfc_error ("Selector at %L must not be coindexed",
8047 &code
->expr1
->where
);
8052 /* Loop over TYPE IS / CLASS IS cases. */
8053 for (body
= code
->block
; body
; body
= body
->block
)
8055 c
= body
->ext
.block
.case_list
;
8057 /* Check F03:C815. */
8058 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8059 && !selector_type
->attr
.unlimited_polymorphic
8060 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8062 gfc_error ("Derived type %qs at %L must be extensible",
8063 c
->ts
.u
.derived
->name
, &c
->where
);
8068 /* Check F03:C816. */
8069 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8070 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8071 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8073 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8074 gfc_error ("Derived type %qs at %L must be an extension of %qs",
8075 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8077 gfc_error ("Unexpected intrinsic type %qs at %L",
8078 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8083 /* Check F03:C814. */
8084 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8086 gfc_error ("The type-spec at %L shall specify that each length "
8087 "type parameter is assumed", &c
->where
);
8092 /* Intercept the DEFAULT case. */
8093 if (c
->ts
.type
== BT_UNKNOWN
)
8095 /* Check F03:C818. */
8098 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
8099 "by a second DEFAULT CASE at %L",
8100 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8105 default_case
= body
;
8112 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8113 target if present. If there are any EXIT statements referring to the
8114 SELECT TYPE construct, this is no problem because the gfc_code
8115 reference stays the same and EXIT is equally possible from the BLOCK
8116 it is changed to. */
8117 code
->op
= EXEC_BLOCK
;
8120 gfc_association_list
* assoc
;
8122 assoc
= gfc_get_association_list ();
8123 assoc
->st
= code
->expr1
->symtree
;
8124 assoc
->target
= gfc_copy_expr (code
->expr2
);
8125 assoc
->target
->where
= code
->expr2
->where
;
8126 /* assoc->variable will be set by resolve_assoc_var. */
8128 code
->ext
.block
.assoc
= assoc
;
8129 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8131 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8134 code
->ext
.block
.assoc
= NULL
;
8136 /* Add EXEC_SELECT to switch on type. */
8137 new_st
= gfc_get_code (code
->op
);
8138 new_st
->expr1
= code
->expr1
;
8139 new_st
->expr2
= code
->expr2
;
8140 new_st
->block
= code
->block
;
8141 code
->expr1
= code
->expr2
= NULL
;
8146 ns
->code
->next
= new_st
;
8148 code
->op
= EXEC_SELECT
;
8150 gfc_add_vptr_component (code
->expr1
);
8151 gfc_add_hash_component (code
->expr1
);
8153 /* Loop over TYPE IS / CLASS IS cases. */
8154 for (body
= code
->block
; body
; body
= body
->block
)
8156 c
= body
->ext
.block
.case_list
;
8158 if (c
->ts
.type
== BT_DERIVED
)
8159 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8160 c
->ts
.u
.derived
->hash_value
);
8161 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8166 ivtab
= gfc_find_vtab (&c
->ts
);
8167 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8168 e
= CLASS_DATA (ivtab
)->initializer
;
8169 c
->low
= c
->high
= gfc_copy_expr (e
);
8172 else if (c
->ts
.type
== BT_UNKNOWN
)
8175 /* Associate temporary to selector. This should only be done
8176 when this case is actually true, so build a new ASSOCIATE
8177 that does precisely this here (instead of using the
8180 if (c
->ts
.type
== BT_CLASS
)
8181 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8182 else if (c
->ts
.type
== BT_DERIVED
)
8183 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8184 else if (c
->ts
.type
== BT_CHARACTER
)
8186 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8187 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8188 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8189 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8190 charlen
, c
->ts
.kind
);
8193 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8196 st
= gfc_find_symtree (ns
->sym_root
, name
);
8197 gcc_assert (st
->n
.sym
->assoc
);
8198 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8199 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8200 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8201 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8203 new_st
= gfc_get_code (EXEC_BLOCK
);
8204 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8205 new_st
->ext
.block
.ns
->code
= body
->next
;
8206 body
->next
= new_st
;
8208 /* Chain in the new list only if it is marked as dangling. Otherwise
8209 there is a CASE label overlap and this is already used. Just ignore,
8210 the error is diagnosed elsewhere. */
8211 if (st
->n
.sym
->assoc
->dangling
)
8213 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8214 st
->n
.sym
->assoc
->dangling
= 0;
8217 resolve_assoc_var (st
->n
.sym
, false);
8220 /* Take out CLASS IS cases for separate treatment. */
8222 while (body
&& body
->block
)
8224 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8226 /* Add to class_is list. */
8227 if (class_is
== NULL
)
8229 class_is
= body
->block
;
8234 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8235 tail
->block
= body
->block
;
8238 /* Remove from EXEC_SELECT list. */
8239 body
->block
= body
->block
->block
;
8252 /* Add a default case to hold the CLASS IS cases. */
8253 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8254 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8256 tail
->ext
.block
.case_list
= gfc_get_case ();
8257 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8259 default_case
= tail
;
8262 /* More than one CLASS IS block? */
8263 if (class_is
->block
)
8267 /* Sort CLASS IS blocks by extension level. */
8271 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8274 /* F03:C817 (check for doubles). */
8275 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8276 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8278 gfc_error ("Double CLASS IS block in SELECT TYPE "
8280 &c2
->ext
.block
.case_list
->where
);
8283 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8284 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8287 (*c1
)->block
= c2
->block
;
8297 /* Generate IF chain. */
8298 if_st
= gfc_get_code (EXEC_IF
);
8300 for (body
= class_is
; body
; body
= body
->block
)
8302 new_st
->block
= gfc_get_code (EXEC_IF
);
8303 new_st
= new_st
->block
;
8304 /* Set up IF condition: Call _gfortran_is_extension_of. */
8305 new_st
->expr1
= gfc_get_expr ();
8306 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8307 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8308 new_st
->expr1
->ts
.kind
= 4;
8309 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8310 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8311 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8312 /* Set up arguments. */
8313 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8314 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8315 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8316 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8317 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8318 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8319 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8320 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8321 new_st
->next
= body
->next
;
8323 if (default_case
->next
)
8325 new_st
->block
= gfc_get_code (EXEC_IF
);
8326 new_st
= new_st
->block
;
8327 new_st
->next
= default_case
->next
;
8330 /* Replace CLASS DEFAULT code by the IF chain. */
8331 default_case
->next
= if_st
;
8334 /* Resolve the internal code. This can not be done earlier because
8335 it requires that the sym->assoc of selectors is set already. */
8336 gfc_current_ns
= ns
;
8337 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8338 gfc_current_ns
= old_ns
;
8340 resolve_select (code
, true);
8344 /* Resolve a transfer statement. This is making sure that:
8345 -- a derived type being transferred has only non-pointer components
8346 -- a derived type being transferred doesn't have private components, unless
8347 it's being transferred from the module where the type was defined
8348 -- we're not trying to transfer a whole assumed size array. */
8351 resolve_transfer (gfc_code
*code
)
8360 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8361 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8362 exp
= exp
->value
.op
.op1
;
8364 if (exp
&& exp
->expr_type
== EXPR_NULL
8367 gfc_error ("Invalid context for NULL () intrinsic at %L",
8372 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8373 && exp
->expr_type
!= EXPR_FUNCTION
8374 && exp
->expr_type
!= EXPR_STRUCTURE
))
8377 /* If we are reading, the variable will be changed. Note that
8378 code->ext.dt may be NULL if the TRANSFER is related to
8379 an INQUIRE statement -- but in this case, we are not reading, either. */
8380 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8381 && !gfc_check_vardef_context (exp
, false, false, false,
8385 ts
= exp
->expr_type
== EXPR_STRUCTURE
? &exp
->ts
: &exp
->symtree
->n
.sym
->ts
;
8387 /* Go to actual component transferred. */
8388 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8389 if (ref
->type
== REF_COMPONENT
)
8390 ts
= &ref
->u
.c
.component
->ts
;
8392 if (ts
->type
== BT_CLASS
)
8394 /* FIXME: Test for defined input/output. */
8395 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8396 "it is processed by a defined input/output procedure",
8401 if (ts
->type
== BT_DERIVED
)
8403 /* Check that transferred derived type doesn't contain POINTER
8405 if (ts
->u
.derived
->attr
.pointer_comp
)
8407 gfc_error ("Data transfer element at %L cannot have POINTER "
8408 "components unless it is processed by a defined "
8409 "input/output procedure", &code
->loc
);
8414 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8416 gfc_error ("Data transfer element at %L cannot have "
8417 "procedure pointer components", &code
->loc
);
8421 if (ts
->u
.derived
->attr
.alloc_comp
)
8423 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8424 "components unless it is processed by a defined "
8425 "input/output procedure", &code
->loc
);
8429 /* C_PTR and C_FUNPTR have private components which means they can not
8430 be printed. However, if -std=gnu and not -pedantic, allow
8431 the component to be printed to help debugging. */
8432 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8434 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8435 "cannot have PRIVATE components", &code
->loc
))
8438 else if (derived_inaccessible (ts
->u
.derived
))
8440 gfc_error ("Data transfer element at %L cannot have "
8441 "PRIVATE components",&code
->loc
);
8446 if (exp
->expr_type
== EXPR_STRUCTURE
)
8449 sym
= exp
->symtree
->n
.sym
;
8451 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8452 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8454 gfc_error ("Data transfer element at %L cannot be a full reference to "
8455 "an assumed-size array", &code
->loc
);
8461 /*********** Toplevel code resolution subroutines ***********/
8463 /* Find the set of labels that are reachable from this block. We also
8464 record the last statement in each block. */
8467 find_reachable_labels (gfc_code
*block
)
8474 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8476 /* Collect labels in this block. We don't keep those corresponding
8477 to END {IF|SELECT}, these are checked in resolve_branch by going
8478 up through the code_stack. */
8479 for (c
= block
; c
; c
= c
->next
)
8481 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8482 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8485 /* Merge with labels from parent block. */
8488 gcc_assert (cs_base
->prev
->reachable_labels
);
8489 bitmap_ior_into (cs_base
->reachable_labels
,
8490 cs_base
->prev
->reachable_labels
);
8496 resolve_lock_unlock (gfc_code
*code
)
8498 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8499 && code
->expr1
->value
.function
.isym
8500 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8501 remove_caf_get_intrinsic (code
->expr1
);
8503 if (code
->expr1
->ts
.type
!= BT_DERIVED
8504 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8505 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8506 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8507 || code
->expr1
->rank
!= 0
8508 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8509 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8510 &code
->expr1
->where
);
8514 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8515 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8516 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8517 &code
->expr2
->where
);
8520 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8521 _("STAT variable")))
8526 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8527 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8528 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8529 &code
->expr3
->where
);
8532 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8533 _("ERRMSG variable")))
8536 /* Check ACQUIRED_LOCK. */
8538 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8539 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8540 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8541 "variable", &code
->expr4
->where
);
8544 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8545 _("ACQUIRED_LOCK variable")))
8551 resolve_critical (gfc_code
*code
)
8553 gfc_symtree
*symtree
;
8554 gfc_symbol
*lock_type
;
8555 char name
[GFC_MAX_SYMBOL_LEN
];
8556 static int serial
= 0;
8558 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
8561 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8562 GFC_PREFIX ("lock_type"));
8564 lock_type
= symtree
->n
.sym
;
8567 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8570 lock_type
= symtree
->n
.sym
;
8571 lock_type
->attr
.flavor
= FL_DERIVED
;
8572 lock_type
->attr
.zero_comp
= 1;
8573 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8574 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8577 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8578 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8581 code
->resolved_sym
= symtree
->n
.sym
;
8582 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8583 symtree
->n
.sym
->attr
.referenced
= 1;
8584 symtree
->n
.sym
->attr
.artificial
= 1;
8585 symtree
->n
.sym
->attr
.codimension
= 1;
8586 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8587 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8588 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8589 symtree
->n
.sym
->as
->corank
= 1;
8590 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8591 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8592 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8598 resolve_sync (gfc_code
*code
)
8600 /* Check imageset. The * case matches expr1 == NULL. */
8603 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8604 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8605 "INTEGER expression", &code
->expr1
->where
);
8606 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8607 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8608 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8609 &code
->expr1
->where
);
8610 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8611 && gfc_simplify_expr (code
->expr1
, 0))
8613 gfc_constructor
*cons
;
8614 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8615 for (; cons
; cons
= gfc_constructor_next (cons
))
8616 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8617 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8618 gfc_error ("Imageset argument at %L must between 1 and "
8619 "num_images()", &cons
->expr
->where
);
8625 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8626 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8627 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8628 &code
->expr2
->where
);
8632 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8633 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8634 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8635 &code
->expr3
->where
);
8639 /* Given a branch to a label, see if the branch is conforming.
8640 The code node describes where the branch is located. */
8643 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8650 /* Step one: is this a valid branching target? */
8652 if (label
->defined
== ST_LABEL_UNKNOWN
)
8654 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8659 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8661 gfc_error_1 ("Statement at %L is not a valid branch target statement "
8662 "for the branch statement at %L", &label
->where
, &code
->loc
);
8666 /* Step two: make sure this branch is not a branch to itself ;-) */
8668 if (code
->here
== label
)
8671 "Branch at %L may result in an infinite loop", &code
->loc
);
8675 /* Step three: See if the label is in the same block as the
8676 branching statement. The hard work has been done by setting up
8677 the bitmap reachable_labels. */
8679 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8681 /* Check now whether there is a CRITICAL construct; if so, check
8682 whether the label is still visible outside of the CRITICAL block,
8683 which is invalid. */
8684 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8686 if (stack
->current
->op
== EXEC_CRITICAL
8687 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8688 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for "
8689 "label at %L", &code
->loc
, &label
->where
);
8690 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8691 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8692 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct "
8693 "for label at %L", &code
->loc
, &label
->where
);
8699 /* Step four: If we haven't found the label in the bitmap, it may
8700 still be the label of the END of the enclosing block, in which
8701 case we find it by going up the code_stack. */
8703 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8705 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8707 if (stack
->current
->op
== EXEC_CRITICAL
)
8709 /* Note: A label at END CRITICAL does not leave the CRITICAL
8710 construct as END CRITICAL is still part of it. */
8711 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label"
8712 " at %L", &code
->loc
, &label
->where
);
8715 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8717 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for "
8718 "label at %L", &code
->loc
, &label
->where
);
8725 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8729 /* The label is not in an enclosing block, so illegal. This was
8730 allowed in Fortran 66, so we allow it as extension. No
8731 further checks are necessary in this case. */
8732 gfc_notify_std_1 (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8733 "as the GOTO statement at %L", &label
->where
,
8739 /* Check whether EXPR1 has the same shape as EXPR2. */
8742 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8744 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8745 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8746 bool result
= false;
8749 /* Compare the rank. */
8750 if (expr1
->rank
!= expr2
->rank
)
8753 /* Compare the size of each dimension. */
8754 for (i
=0; i
<expr1
->rank
; i
++)
8756 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8759 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8762 if (mpz_cmp (shape
[i
], shape2
[i
]))
8766 /* When either of the two expression is an assumed size array, we
8767 ignore the comparison of dimension sizes. */
8772 gfc_clear_shape (shape
, i
);
8773 gfc_clear_shape (shape2
, i
);
8778 /* Check whether a WHERE assignment target or a WHERE mask expression
8779 has the same shape as the outmost WHERE mask expression. */
8782 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8788 cblock
= code
->block
;
8790 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8791 In case of nested WHERE, only the outmost one is stored. */
8792 if (mask
== NULL
) /* outmost WHERE */
8794 else /* inner WHERE */
8801 /* Check if the mask-expr has a consistent shape with the
8802 outmost WHERE mask-expr. */
8803 if (!resolve_where_shape (cblock
->expr1
, e
))
8804 gfc_error ("WHERE mask at %L has inconsistent shape",
8805 &cblock
->expr1
->where
);
8808 /* the assignment statement of a WHERE statement, or the first
8809 statement in where-body-construct of a WHERE construct */
8810 cnext
= cblock
->next
;
8815 /* WHERE assignment statement */
8818 /* Check shape consistent for WHERE assignment target. */
8819 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8820 gfc_error ("WHERE assignment target at %L has "
8821 "inconsistent shape", &cnext
->expr1
->where
);
8825 case EXEC_ASSIGN_CALL
:
8826 resolve_call (cnext
);
8827 if (!cnext
->resolved_sym
->attr
.elemental
)
8828 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8829 &cnext
->ext
.actual
->expr
->where
);
8832 /* WHERE or WHERE construct is part of a where-body-construct */
8834 resolve_where (cnext
, e
);
8838 gfc_error ("Unsupported statement inside WHERE at %L",
8841 /* the next statement within the same where-body-construct */
8842 cnext
= cnext
->next
;
8844 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8845 cblock
= cblock
->block
;
8850 /* Resolve assignment in FORALL construct.
8851 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8852 FORALL index variables. */
8855 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8859 for (n
= 0; n
< nvar
; n
++)
8861 gfc_symbol
*forall_index
;
8863 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8865 /* Check whether the assignment target is one of the FORALL index
8867 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8868 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8869 gfc_error ("Assignment to a FORALL index variable at %L",
8870 &code
->expr1
->where
);
8873 /* If one of the FORALL index variables doesn't appear in the
8874 assignment variable, then there could be a many-to-one
8875 assignment. Emit a warning rather than an error because the
8876 mask could be resolving this problem. */
8877 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8878 gfc_warning (0, "The FORALL with index %qs is not used on the "
8879 "left side of the assignment at %L and so might "
8880 "cause multiple assignment to this object",
8881 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8887 /* Resolve WHERE statement in FORALL construct. */
8890 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8891 gfc_expr
**var_expr
)
8896 cblock
= code
->block
;
8899 /* the assignment statement of a WHERE statement, or the first
8900 statement in where-body-construct of a WHERE construct */
8901 cnext
= cblock
->next
;
8906 /* WHERE assignment statement */
8908 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8911 /* WHERE operator assignment statement */
8912 case EXEC_ASSIGN_CALL
:
8913 resolve_call (cnext
);
8914 if (!cnext
->resolved_sym
->attr
.elemental
)
8915 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8916 &cnext
->ext
.actual
->expr
->where
);
8919 /* WHERE or WHERE construct is part of a where-body-construct */
8921 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8925 gfc_error ("Unsupported statement inside WHERE at %L",
8928 /* the next statement within the same where-body-construct */
8929 cnext
= cnext
->next
;
8931 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8932 cblock
= cblock
->block
;
8937 /* Traverse the FORALL body to check whether the following errors exist:
8938 1. For assignment, check if a many-to-one assignment happens.
8939 2. For WHERE statement, check the WHERE body to see if there is any
8940 many-to-one assignment. */
8943 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8947 c
= code
->block
->next
;
8953 case EXEC_POINTER_ASSIGN
:
8954 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8957 case EXEC_ASSIGN_CALL
:
8961 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8962 there is no need to handle it here. */
8966 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8971 /* The next statement in the FORALL body. */
8977 /* Counts the number of iterators needed inside a forall construct, including
8978 nested forall constructs. This is used to allocate the needed memory
8979 in gfc_resolve_forall. */
8982 gfc_count_forall_iterators (gfc_code
*code
)
8984 int max_iters
, sub_iters
, current_iters
;
8985 gfc_forall_iterator
*fa
;
8987 gcc_assert(code
->op
== EXEC_FORALL
);
8991 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8994 code
= code
->block
->next
;
8998 if (code
->op
== EXEC_FORALL
)
9000 sub_iters
= gfc_count_forall_iterators (code
);
9001 if (sub_iters
> max_iters
)
9002 max_iters
= sub_iters
;
9007 return current_iters
+ max_iters
;
9011 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9012 gfc_resolve_forall_body to resolve the FORALL body. */
9015 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9017 static gfc_expr
**var_expr
;
9018 static int total_var
= 0;
9019 static int nvar
= 0;
9021 gfc_forall_iterator
*fa
;
9026 /* Start to resolve a FORALL construct */
9027 if (forall_save
== 0)
9029 /* Count the total number of FORALL index in the nested FORALL
9030 construct in order to allocate the VAR_EXPR with proper size. */
9031 total_var
= gfc_count_forall_iterators (code
);
9033 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9034 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9037 /* The information about FORALL iterator, including FORALL index start, end
9038 and stride. The FORALL index can not appear in start, end or stride. */
9039 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9041 /* Check if any outer FORALL index name is the same as the current
9043 for (i
= 0; i
< nvar
; i
++)
9045 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9047 gfc_error ("An outer FORALL construct already has an index "
9048 "with this name %L", &fa
->var
->where
);
9052 /* Record the current FORALL index. */
9053 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9057 /* No memory leak. */
9058 gcc_assert (nvar
<= total_var
);
9061 /* Resolve the FORALL body. */
9062 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9064 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9065 gfc_resolve_blocks (code
->block
, ns
);
9069 /* Free only the VAR_EXPRs allocated in this frame. */
9070 for (i
= nvar
; i
< tmp
; i
++)
9071 gfc_free_expr (var_expr
[i
]);
9075 /* We are in the outermost FORALL construct. */
9076 gcc_assert (forall_save
== 0);
9078 /* VAR_EXPR is not needed any more. */
9085 /* Resolve a BLOCK construct statement. */
9088 resolve_block_construct (gfc_code
* code
)
9090 /* Resolve the BLOCK's namespace. */
9091 gfc_resolve (code
->ext
.block
.ns
);
9093 /* For an ASSOCIATE block, the associations (and their targets) are already
9094 resolved during resolve_symbol. */
9098 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9102 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9106 for (; b
; b
= b
->block
)
9108 t
= gfc_resolve_expr (b
->expr1
);
9109 if (!gfc_resolve_expr (b
->expr2
))
9115 if (t
&& b
->expr1
!= NULL
9116 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9117 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9124 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9125 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9130 resolve_branch (b
->label1
, b
);
9134 resolve_block_construct (b
);
9138 case EXEC_SELECT_TYPE
:
9142 case EXEC_DO_CONCURRENT
:
9150 case EXEC_OACC_PARALLEL_LOOP
:
9151 case EXEC_OACC_PARALLEL
:
9152 case EXEC_OACC_KERNELS_LOOP
:
9153 case EXEC_OACC_KERNELS
:
9154 case EXEC_OACC_DATA
:
9155 case EXEC_OACC_HOST_DATA
:
9156 case EXEC_OACC_LOOP
:
9157 case EXEC_OACC_UPDATE
:
9158 case EXEC_OACC_WAIT
:
9159 case EXEC_OACC_CACHE
:
9160 case EXEC_OACC_ENTER_DATA
:
9161 case EXEC_OACC_EXIT_DATA
:
9162 case EXEC_OMP_ATOMIC
:
9163 case EXEC_OMP_CRITICAL
:
9164 case EXEC_OMP_DISTRIBUTE
:
9165 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9166 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9167 case EXEC_OMP_DISTRIBUTE_SIMD
:
9169 case EXEC_OMP_DO_SIMD
:
9170 case EXEC_OMP_MASTER
:
9171 case EXEC_OMP_ORDERED
:
9172 case EXEC_OMP_PARALLEL
:
9173 case EXEC_OMP_PARALLEL_DO
:
9174 case EXEC_OMP_PARALLEL_DO_SIMD
:
9175 case EXEC_OMP_PARALLEL_SECTIONS
:
9176 case EXEC_OMP_PARALLEL_WORKSHARE
:
9177 case EXEC_OMP_SECTIONS
:
9179 case EXEC_OMP_SINGLE
:
9180 case EXEC_OMP_TARGET
:
9181 case EXEC_OMP_TARGET_DATA
:
9182 case EXEC_OMP_TARGET_TEAMS
:
9183 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9184 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9185 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9186 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9187 case EXEC_OMP_TARGET_UPDATE
:
9189 case EXEC_OMP_TASKGROUP
:
9190 case EXEC_OMP_TASKWAIT
:
9191 case EXEC_OMP_TASKYIELD
:
9192 case EXEC_OMP_TEAMS
:
9193 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9194 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9195 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9196 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9197 case EXEC_OMP_WORKSHARE
:
9201 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9204 gfc_resolve_code (b
->next
, ns
);
9209 /* Does everything to resolve an ordinary assignment. Returns true
9210 if this is an interface assignment. */
9212 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9221 symbol_attribute attr
;
9223 if (gfc_extend_assign (code
, ns
))
9227 if (code
->op
== EXEC_ASSIGN_CALL
)
9229 lhs
= code
->ext
.actual
->expr
;
9230 rhsptr
= &code
->ext
.actual
->next
->expr
;
9234 gfc_actual_arglist
* args
;
9235 gfc_typebound_proc
* tbp
;
9237 gcc_assert (code
->op
== EXEC_COMPCALL
);
9239 args
= code
->expr1
->value
.compcall
.actual
;
9241 rhsptr
= &args
->next
->expr
;
9243 tbp
= code
->expr1
->value
.compcall
.tbp
;
9244 gcc_assert (!tbp
->is_generic
);
9247 /* Make a temporary rhs when there is a default initializer
9248 and rhs is the same symbol as the lhs. */
9249 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9250 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9251 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9252 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9253 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9262 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9263 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9267 /* Handle the case of a BOZ literal on the RHS. */
9268 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9271 if (warn_surprising
)
9272 gfc_warning (OPT_Wsurprising
,
9273 "BOZ literal at %L is bitwise transferred "
9274 "non-integer symbol %qs", &code
->loc
,
9275 lhs
->symtree
->n
.sym
->name
);
9277 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9279 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9281 if (rc
== ARITH_UNDERFLOW
)
9282 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9283 ". This check can be disabled with the option "
9284 "%<-fno-range-check%>", &rhs
->where
);
9285 else if (rc
== ARITH_OVERFLOW
)
9286 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9287 ". This check can be disabled with the option "
9288 "%<-fno-range-check%>", &rhs
->where
);
9289 else if (rc
== ARITH_NAN
)
9290 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9291 ". This check can be disabled with the option "
9292 "%<-fno-range-check%>", &rhs
->where
);
9297 if (lhs
->ts
.type
== BT_CHARACTER
9298 && warn_character_truncation
)
9300 if (lhs
->ts
.u
.cl
!= NULL
9301 && lhs
->ts
.u
.cl
->length
!= NULL
9302 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9303 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9305 if (rhs
->expr_type
== EXPR_CONSTANT
)
9306 rlen
= rhs
->value
.character
.length
;
9308 else if (rhs
->ts
.u
.cl
!= NULL
9309 && rhs
->ts
.u
.cl
->length
!= NULL
9310 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9311 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9313 if (rlen
&& llen
&& rlen
> llen
)
9314 gfc_warning_now (OPT_Wcharacter_truncation
,
9315 "CHARACTER expression will be truncated "
9316 "in assignment (%d/%d) at %L",
9317 llen
, rlen
, &code
->loc
);
9320 /* Ensure that a vector index expression for the lvalue is evaluated
9321 to a temporary if the lvalue symbol is referenced in it. */
9324 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9325 if (ref
->type
== REF_ARRAY
)
9327 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9328 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9329 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9330 ref
->u
.ar
.start
[n
]))
9332 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9336 if (gfc_pure (NULL
))
9338 if (lhs
->ts
.type
== BT_DERIVED
9339 && lhs
->expr_type
== EXPR_VARIABLE
9340 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9341 && rhs
->expr_type
== EXPR_VARIABLE
9342 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9343 || gfc_is_coindexed (rhs
)))
9346 if (gfc_is_coindexed (rhs
))
9347 gfc_error ("Coindexed expression at %L is assigned to "
9348 "a derived type variable with a POINTER "
9349 "component in a PURE procedure",
9352 gfc_error ("The impure variable at %L is assigned to "
9353 "a derived type variable with a POINTER "
9354 "component in a PURE procedure (12.6)",
9359 /* Fortran 2008, C1283. */
9360 if (gfc_is_coindexed (lhs
))
9362 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9363 "procedure", &rhs
->where
);
9368 if (gfc_implicit_pure (NULL
))
9370 if (lhs
->expr_type
== EXPR_VARIABLE
9371 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9372 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9373 gfc_unset_implicit_pure (NULL
);
9375 if (lhs
->ts
.type
== BT_DERIVED
9376 && lhs
->expr_type
== EXPR_VARIABLE
9377 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9378 && rhs
->expr_type
== EXPR_VARIABLE
9379 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9380 || gfc_is_coindexed (rhs
)))
9381 gfc_unset_implicit_pure (NULL
);
9383 /* Fortran 2008, C1283. */
9384 if (gfc_is_coindexed (lhs
))
9385 gfc_unset_implicit_pure (NULL
);
9388 /* F2008, 7.2.1.2. */
9389 attr
= gfc_expr_attr (lhs
);
9390 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9392 if (attr
.codimension
)
9394 gfc_error ("Assignment to polymorphic coarray at %L is not "
9395 "permitted", &lhs
->where
);
9398 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9399 "polymorphic variable at %L", &lhs
->where
))
9401 if (!flag_realloc_lhs
)
9403 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9404 "requires %<-frealloc-lhs%>", &lhs
->where
);
9408 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9409 "is not yet supported", &lhs
->where
);
9412 else if (lhs
->ts
.type
== BT_CLASS
)
9414 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9415 "assignment at %L - check that there is a matching specific "
9416 "subroutine for '=' operator", &lhs
->where
);
9420 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9422 /* F2008, Section 7.2.1.2. */
9423 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9425 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9426 "component in assignment at %L", &lhs
->where
);
9430 gfc_check_assign (lhs
, rhs
, 1);
9432 /* Assign the 'data' of a class object to a derived type. */
9433 if (lhs
->ts
.type
== BT_DERIVED
9434 && rhs
->ts
.type
== BT_CLASS
)
9435 gfc_add_data_component (rhs
);
9437 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9438 Additionally, insert this code when the RHS is a CAF as we then use the
9439 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9440 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9441 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9443 if (flag_coarray
== GFC_FCOARRAY_LIB
9445 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9446 && code
->expr2
->value
.function
.isym
9447 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9448 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9449 && !gfc_expr_attr (rhs
).allocatable
9450 && !gfc_has_vector_subscript (rhs
))))
9452 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9453 && code
->expr2
->value
.function
.isym
9454 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9455 remove_caf_get_intrinsic (code
->expr2
);
9456 code
->op
= EXEC_CALL
;
9457 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9458 code
->resolved_sym
= code
->symtree
->n
.sym
;
9459 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9460 code
->resolved_sym
->attr
.intrinsic
= 1;
9461 code
->resolved_sym
->attr
.subroutine
= 1;
9462 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9463 gfc_commit_symbol (code
->resolved_sym
);
9464 code
->ext
.actual
= gfc_get_actual_arglist ();
9465 code
->ext
.actual
->expr
= lhs
;
9466 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9467 code
->ext
.actual
->next
->expr
= rhs
;
9476 /* Add a component reference onto an expression. */
9479 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9484 ref
= &((*ref
)->next
);
9485 *ref
= gfc_get_ref ();
9486 (*ref
)->type
= REF_COMPONENT
;
9487 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9488 (*ref
)->u
.c
.component
= c
;
9491 /* Add a full array ref, as necessary. */
9494 gfc_add_full_array_ref (e
, c
->as
);
9495 e
->rank
= c
->as
->rank
;
9500 /* Build an assignment. Keep the argument 'op' for future use, so that
9501 pointer assignments can be made. */
9504 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9505 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9507 gfc_code
*this_code
;
9509 this_code
= gfc_get_code (op
);
9510 this_code
->next
= NULL
;
9511 this_code
->expr1
= gfc_copy_expr (expr1
);
9512 this_code
->expr2
= gfc_copy_expr (expr2
);
9513 this_code
->loc
= loc
;
9516 add_comp_ref (this_code
->expr1
, comp1
);
9517 add_comp_ref (this_code
->expr2
, comp2
);
9524 /* Makes a temporary variable expression based on the characteristics of
9525 a given variable expression. */
9528 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9530 static int serial
= 0;
9531 char name
[GFC_MAX_SYMBOL_LEN
];
9534 gfc_array_ref
*aref
;
9537 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9538 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9539 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9545 /* This function could be expanded to support other expression type
9546 but this is not needed here. */
9547 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9549 /* Obtain the arrayspec for the temporary. */
9552 aref
= gfc_find_array_ref (e
);
9553 if (e
->expr_type
== EXPR_VARIABLE
9554 && e
->symtree
->n
.sym
->as
== aref
->as
)
9558 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9559 if (ref
->type
== REF_COMPONENT
9560 && ref
->u
.c
.component
->as
== aref
->as
)
9568 /* Add the attributes and the arrayspec to the temporary. */
9569 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9570 tmp
->n
.sym
->attr
.function
= 0;
9571 tmp
->n
.sym
->attr
.result
= 0;
9572 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9576 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9579 if (as
->type
== AS_DEFERRED
)
9580 tmp
->n
.sym
->attr
.allocatable
= 1;
9583 tmp
->n
.sym
->attr
.dimension
= 0;
9585 gfc_set_sym_referenced (tmp
->n
.sym
);
9586 gfc_commit_symbol (tmp
->n
.sym
);
9587 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9589 /* Should the lhs be a section, use its array ref for the
9590 temporary expression. */
9591 if (aref
&& aref
->type
!= AR_FULL
)
9593 gfc_free_ref_list (e
->ref
);
9594 e
->ref
= gfc_copy_ref (ref
);
9600 /* Add one line of code to the code chain, making sure that 'head' and
9601 'tail' are appropriately updated. */
9604 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9606 gcc_assert (this_code
);
9608 *head
= *tail
= *this_code
;
9610 *tail
= gfc_append_code (*tail
, *this_code
);
9615 /* Counts the potential number of part array references that would
9616 result from resolution of typebound defined assignments. */
9619 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9622 int c_depth
= 0, t_depth
;
9624 for (c
= derived
->components
; c
; c
= c
->next
)
9626 if ((c
->ts
.type
!= BT_DERIVED
9628 || c
->attr
.allocatable
9629 || c
->attr
.proc_pointer_comp
9630 || c
->attr
.class_pointer
9631 || c
->attr
.proc_pointer
)
9632 && !c
->attr
.defined_assign_comp
)
9635 if (c
->as
&& c_depth
== 0)
9638 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9639 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9644 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9646 return depth
+ c_depth
;
9650 /* Implement 7.2.1.3 of the F08 standard:
9651 "An intrinsic assignment where the variable is of derived type is
9652 performed as if each component of the variable were assigned from the
9653 corresponding component of expr using pointer assignment (7.2.2) for
9654 each pointer component, defined assignment for each nonpointer
9655 nonallocatable component of a type that has a type-bound defined
9656 assignment consistent with the component, intrinsic assignment for
9657 each other nonpointer nonallocatable component, ..."
9659 The pointer assignments are taken care of by the intrinsic
9660 assignment of the structure itself. This function recursively adds
9661 defined assignments where required. The recursion is accomplished
9662 by calling gfc_resolve_code.
9664 When the lhs in a defined assignment has intent INOUT, we need a
9665 temporary for the lhs. In pseudo-code:
9667 ! Only call function lhs once.
9668 if (lhs is not a constant or an variable)
9671 ! Do the intrinsic assignment
9673 ! Now do the defined assignments
9674 do over components with typebound defined assignment [%cmp]
9675 #if one component's assignment procedure is INOUT
9677 #if expr2 non-variable
9683 t1%cmp {defined=} expr2%cmp
9689 expr1%cmp {defined=} expr2%cmp
9693 /* The temporary assignments have to be put on top of the additional
9694 code to avoid the result being changed by the intrinsic assignment.
9696 static int component_assignment_level
= 0;
9697 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9700 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9702 gfc_component
*comp1
, *comp2
;
9703 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9705 int error_count
, depth
;
9707 gfc_get_errors (NULL
, &error_count
);
9709 /* Filter out continuing processing after an error. */
9711 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9712 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9715 /* TODO: Handle more than one part array reference in assignments. */
9716 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9717 (*code
)->expr1
->rank
? 1 : 0);
9720 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not "
9721 "done because multiple part array references would "
9722 "occur in intermediate expressions.", &(*code
)->loc
);
9726 component_assignment_level
++;
9728 /* Create a temporary so that functions get called only once. */
9729 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9730 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9734 /* Assign the rhs to the temporary. */
9735 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9736 this_code
= build_assignment (EXEC_ASSIGN
,
9737 tmp_expr
, (*code
)->expr2
,
9738 NULL
, NULL
, (*code
)->loc
);
9739 /* Add the code and substitute the rhs expression. */
9740 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9741 gfc_free_expr ((*code
)->expr2
);
9742 (*code
)->expr2
= tmp_expr
;
9745 /* Do the intrinsic assignment. This is not needed if the lhs is one
9746 of the temporaries generated here, since the intrinsic assignment
9747 to the final result already does this. */
9748 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9750 this_code
= build_assignment (EXEC_ASSIGN
,
9751 (*code
)->expr1
, (*code
)->expr2
,
9752 NULL
, NULL
, (*code
)->loc
);
9753 add_code_to_chain (&this_code
, &head
, &tail
);
9756 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9757 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9760 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9764 /* The intrinsic assignment does the right thing for pointers
9765 of all kinds and allocatable components. */
9766 if (comp1
->ts
.type
!= BT_DERIVED
9767 || comp1
->attr
.pointer
9768 || comp1
->attr
.allocatable
9769 || comp1
->attr
.proc_pointer_comp
9770 || comp1
->attr
.class_pointer
9771 || comp1
->attr
.proc_pointer
)
9774 /* Make an assigment for this component. */
9775 this_code
= build_assignment (EXEC_ASSIGN
,
9776 (*code
)->expr1
, (*code
)->expr2
,
9777 comp1
, comp2
, (*code
)->loc
);
9779 /* Convert the assignment if there is a defined assignment for
9780 this type. Otherwise, using the call from gfc_resolve_code,
9781 recurse into its components. */
9782 gfc_resolve_code (this_code
, ns
);
9784 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9786 gfc_formal_arglist
*dummy_args
;
9788 /* Check that there is a typebound defined assignment. If not,
9789 then this must be a module defined assignment. We cannot
9790 use the defined_assign_comp attribute here because it must
9791 be this derived type that has the defined assignment and not
9793 if (!(comp1
->ts
.u
.derived
->f2k_derived
9794 && comp1
->ts
.u
.derived
->f2k_derived
9795 ->tb_op
[INTRINSIC_ASSIGN
]))
9797 gfc_free_statements (this_code
);
9802 /* If the first argument of the subroutine has intent INOUT
9803 a temporary must be generated and used instead. */
9804 rsym
= this_code
->resolved_sym
;
9805 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9807 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9809 gfc_code
*temp_code
;
9812 /* Build the temporary required for the assignment and put
9813 it at the head of the generated code. */
9816 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9817 temp_code
= build_assignment (EXEC_ASSIGN
,
9819 NULL
, NULL
, (*code
)->loc
);
9821 /* For allocatable LHS, check whether it is allocated. Note
9822 that allocatable components with defined assignment are
9823 not yet support. See PR 57696. */
9824 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9828 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9829 block
= gfc_get_code (EXEC_IF
);
9830 block
->block
= gfc_get_code (EXEC_IF
);
9832 = gfc_build_intrinsic_call (ns
,
9833 GFC_ISYM_ALLOCATED
, "allocated",
9834 (*code
)->loc
, 1, e
);
9835 block
->block
->next
= temp_code
;
9838 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9841 /* Replace the first actual arg with the component of the
9843 gfc_free_expr (this_code
->ext
.actual
->expr
);
9844 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9845 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9847 /* If the LHS variable is allocatable and wasn't allocated and
9848 the temporary is allocatable, pointer assign the address of
9849 the freshly allocated LHS to the temporary. */
9850 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9851 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9856 cond
= gfc_get_expr ();
9857 cond
->ts
.type
= BT_LOGICAL
;
9858 cond
->ts
.kind
= gfc_default_logical_kind
;
9859 cond
->expr_type
= EXPR_OP
;
9860 cond
->where
= (*code
)->loc
;
9861 cond
->value
.op
.op
= INTRINSIC_NOT
;
9862 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9863 GFC_ISYM_ALLOCATED
, "allocated",
9864 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9865 block
= gfc_get_code (EXEC_IF
);
9866 block
->block
= gfc_get_code (EXEC_IF
);
9867 block
->block
->expr1
= cond
;
9868 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9870 NULL
, NULL
, (*code
)->loc
);
9871 add_code_to_chain (&block
, &head
, &tail
);
9875 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9877 /* Don't add intrinsic assignments since they are already
9878 effected by the intrinsic assignment of the structure. */
9879 gfc_free_statements (this_code
);
9884 add_code_to_chain (&this_code
, &head
, &tail
);
9888 /* Transfer the value to the final result. */
9889 this_code
= build_assignment (EXEC_ASSIGN
,
9891 comp1
, comp2
, (*code
)->loc
);
9892 add_code_to_chain (&this_code
, &head
, &tail
);
9896 /* Put the temporary assignments at the top of the generated code. */
9897 if (tmp_head
&& component_assignment_level
== 1)
9899 gfc_append_code (tmp_head
, head
);
9901 tmp_head
= tmp_tail
= NULL
;
9904 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9905 // not accidentally deallocated. Hence, nullify t1.
9906 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9907 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9913 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9914 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9915 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9916 block
= gfc_get_code (EXEC_IF
);
9917 block
->block
= gfc_get_code (EXEC_IF
);
9918 block
->block
->expr1
= cond
;
9919 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9920 t1
, gfc_get_null_expr (&(*code
)->loc
),
9921 NULL
, NULL
, (*code
)->loc
);
9922 gfc_append_code (tail
, block
);
9926 /* Now attach the remaining code chain to the input code. Step on
9927 to the end of the new code since resolution is complete. */
9928 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9929 tail
->next
= (*code
)->next
;
9930 /* Overwrite 'code' because this would place the intrinsic assignment
9931 before the temporary for the lhs is created. */
9932 gfc_free_expr ((*code
)->expr1
);
9933 gfc_free_expr ((*code
)->expr2
);
9939 component_assignment_level
--;
9943 /* Given a block of code, recursively resolve everything pointed to by this
9947 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9949 int omp_workshare_save
;
9950 int forall_save
, do_concurrent_save
;
9954 frame
.prev
= cs_base
;
9958 find_reachable_labels (code
);
9960 for (; code
; code
= code
->next
)
9962 frame
.current
= code
;
9963 forall_save
= forall_flag
;
9964 do_concurrent_save
= gfc_do_concurrent_flag
;
9966 if (code
->op
== EXEC_FORALL
)
9969 gfc_resolve_forall (code
, ns
, forall_save
);
9972 else if (code
->block
)
9974 omp_workshare_save
= -1;
9977 case EXEC_OACC_PARALLEL_LOOP
:
9978 case EXEC_OACC_PARALLEL
:
9979 case EXEC_OACC_KERNELS_LOOP
:
9980 case EXEC_OACC_KERNELS
:
9981 case EXEC_OACC_DATA
:
9982 case EXEC_OACC_HOST_DATA
:
9983 case EXEC_OACC_LOOP
:
9984 gfc_resolve_oacc_blocks (code
, ns
);
9986 case EXEC_OMP_PARALLEL_WORKSHARE
:
9987 omp_workshare_save
= omp_workshare_flag
;
9988 omp_workshare_flag
= 1;
9989 gfc_resolve_omp_parallel_blocks (code
, ns
);
9991 case EXEC_OMP_PARALLEL
:
9992 case EXEC_OMP_PARALLEL_DO
:
9993 case EXEC_OMP_PARALLEL_DO_SIMD
:
9994 case EXEC_OMP_PARALLEL_SECTIONS
:
9995 case EXEC_OMP_TARGET_TEAMS
:
9996 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9997 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9998 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9999 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10000 case EXEC_OMP_TASK
:
10001 case EXEC_OMP_TEAMS
:
10002 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10003 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10004 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10005 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10006 omp_workshare_save
= omp_workshare_flag
;
10007 omp_workshare_flag
= 0;
10008 gfc_resolve_omp_parallel_blocks (code
, ns
);
10010 case EXEC_OMP_DISTRIBUTE
:
10011 case EXEC_OMP_DISTRIBUTE_SIMD
:
10013 case EXEC_OMP_DO_SIMD
:
10014 case EXEC_OMP_SIMD
:
10015 gfc_resolve_omp_do_blocks (code
, ns
);
10017 case EXEC_SELECT_TYPE
:
10018 /* Blocks are handled in resolve_select_type because we have
10019 to transform the SELECT TYPE into ASSOCIATE first. */
10021 case EXEC_DO_CONCURRENT
:
10022 gfc_do_concurrent_flag
= 1;
10023 gfc_resolve_blocks (code
->block
, ns
);
10024 gfc_do_concurrent_flag
= 2;
10026 case EXEC_OMP_WORKSHARE
:
10027 omp_workshare_save
= omp_workshare_flag
;
10028 omp_workshare_flag
= 1;
10031 gfc_resolve_blocks (code
->block
, ns
);
10035 if (omp_workshare_save
!= -1)
10036 omp_workshare_flag
= omp_workshare_save
;
10040 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10041 t
= gfc_resolve_expr (code
->expr1
);
10042 forall_flag
= forall_save
;
10043 gfc_do_concurrent_flag
= do_concurrent_save
;
10045 if (!gfc_resolve_expr (code
->expr2
))
10048 if (code
->op
== EXEC_ALLOCATE
10049 && !gfc_resolve_expr (code
->expr3
))
10055 case EXEC_END_BLOCK
:
10056 case EXEC_END_NESTED_BLOCK
:
10060 case EXEC_ERROR_STOP
:
10062 case EXEC_CONTINUE
:
10064 case EXEC_ASSIGN_CALL
:
10067 case EXEC_CRITICAL
:
10068 resolve_critical (code
);
10071 case EXEC_SYNC_ALL
:
10072 case EXEC_SYNC_IMAGES
:
10073 case EXEC_SYNC_MEMORY
:
10074 resolve_sync (code
);
10079 resolve_lock_unlock (code
);
10083 /* Keep track of which entry we are up to. */
10084 current_entry_id
= code
->ext
.entry
->id
;
10088 resolve_where (code
, NULL
);
10092 if (code
->expr1
!= NULL
)
10094 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10095 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10096 "INTEGER variable", &code
->expr1
->where
);
10097 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10098 gfc_error ("Variable %qs has not been assigned a target "
10099 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10100 &code
->expr1
->where
);
10103 resolve_branch (code
->label1
, code
);
10107 if (code
->expr1
!= NULL
10108 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10109 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10110 "INTEGER return specifier", &code
->expr1
->where
);
10113 case EXEC_INIT_ASSIGN
:
10114 case EXEC_END_PROCEDURE
:
10121 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10123 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10124 && code
->expr1
->value
.function
.isym
10125 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10126 remove_caf_get_intrinsic (code
->expr1
);
10128 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10132 if (resolve_ordinary_assign (code
, ns
))
10134 if (code
->op
== EXEC_COMPCALL
)
10140 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10141 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10142 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10143 generate_component_assignments (&code
, ns
);
10147 case EXEC_LABEL_ASSIGN
:
10148 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10149 gfc_error ("Label %d referenced at %L is never defined",
10150 code
->label1
->value
, &code
->label1
->where
);
10152 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10153 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10154 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10155 != gfc_default_integer_kind
10156 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10157 gfc_error ("ASSIGN statement at %L requires a scalar "
10158 "default INTEGER variable", &code
->expr1
->where
);
10161 case EXEC_POINTER_ASSIGN
:
10168 /* This is both a variable definition and pointer assignment
10169 context, so check both of them. For rank remapping, a final
10170 array ref may be present on the LHS and fool gfc_expr_attr
10171 used in gfc_check_vardef_context. Remove it. */
10172 e
= remove_last_array_ref (code
->expr1
);
10173 t
= gfc_check_vardef_context (e
, true, false, false,
10174 _("pointer assignment"));
10176 t
= gfc_check_vardef_context (e
, false, false, false,
10177 _("pointer assignment"));
10182 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10186 case EXEC_ARITHMETIC_IF
:
10188 && code
->expr1
->ts
.type
!= BT_INTEGER
10189 && code
->expr1
->ts
.type
!= BT_REAL
)
10190 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10191 "expression", &code
->expr1
->where
);
10193 resolve_branch (code
->label1
, code
);
10194 resolve_branch (code
->label2
, code
);
10195 resolve_branch (code
->label3
, code
);
10199 if (t
&& code
->expr1
!= NULL
10200 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10201 || code
->expr1
->rank
!= 0))
10202 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10203 &code
->expr1
->where
);
10208 resolve_call (code
);
10211 case EXEC_COMPCALL
:
10213 resolve_typebound_subroutine (code
);
10216 case EXEC_CALL_PPC
:
10217 resolve_ppc_call (code
);
10221 /* Select is complicated. Also, a SELECT construct could be
10222 a transformed computed GOTO. */
10223 resolve_select (code
, false);
10226 case EXEC_SELECT_TYPE
:
10227 resolve_select_type (code
, ns
);
10231 resolve_block_construct (code
);
10235 if (code
->ext
.iterator
!= NULL
)
10237 gfc_iterator
*iter
= code
->ext
.iterator
;
10238 if (gfc_resolve_iterator (iter
, true, false))
10239 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10243 case EXEC_DO_WHILE
:
10244 if (code
->expr1
== NULL
)
10245 gfc_internal_error ("gfc_resolve_code(): No expression on "
10248 && (code
->expr1
->rank
!= 0
10249 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10250 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10251 "a scalar LOGICAL expression", &code
->expr1
->where
);
10254 case EXEC_ALLOCATE
:
10256 resolve_allocate_deallocate (code
, "ALLOCATE");
10260 case EXEC_DEALLOCATE
:
10262 resolve_allocate_deallocate (code
, "DEALLOCATE");
10267 if (!gfc_resolve_open (code
->ext
.open
))
10270 resolve_branch (code
->ext
.open
->err
, code
);
10274 if (!gfc_resolve_close (code
->ext
.close
))
10277 resolve_branch (code
->ext
.close
->err
, code
);
10280 case EXEC_BACKSPACE
:
10284 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10287 resolve_branch (code
->ext
.filepos
->err
, code
);
10291 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10294 resolve_branch (code
->ext
.inquire
->err
, code
);
10297 case EXEC_IOLENGTH
:
10298 gcc_assert (code
->ext
.inquire
!= NULL
);
10299 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10302 resolve_branch (code
->ext
.inquire
->err
, code
);
10306 if (!gfc_resolve_wait (code
->ext
.wait
))
10309 resolve_branch (code
->ext
.wait
->err
, code
);
10310 resolve_branch (code
->ext
.wait
->end
, code
);
10311 resolve_branch (code
->ext
.wait
->eor
, code
);
10316 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10319 resolve_branch (code
->ext
.dt
->err
, code
);
10320 resolve_branch (code
->ext
.dt
->end
, code
);
10321 resolve_branch (code
->ext
.dt
->eor
, code
);
10324 case EXEC_TRANSFER
:
10325 resolve_transfer (code
);
10328 case EXEC_DO_CONCURRENT
:
10330 resolve_forall_iterators (code
->ext
.forall_iterator
);
10332 if (code
->expr1
!= NULL
10333 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10334 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10335 "expression", &code
->expr1
->where
);
10338 case EXEC_OACC_PARALLEL_LOOP
:
10339 case EXEC_OACC_PARALLEL
:
10340 case EXEC_OACC_KERNELS_LOOP
:
10341 case EXEC_OACC_KERNELS
:
10342 case EXEC_OACC_DATA
:
10343 case EXEC_OACC_HOST_DATA
:
10344 case EXEC_OACC_LOOP
:
10345 case EXEC_OACC_UPDATE
:
10346 case EXEC_OACC_WAIT
:
10347 case EXEC_OACC_CACHE
:
10348 case EXEC_OACC_ENTER_DATA
:
10349 case EXEC_OACC_EXIT_DATA
:
10350 gfc_resolve_oacc_directive (code
, ns
);
10353 case EXEC_OMP_ATOMIC
:
10354 case EXEC_OMP_BARRIER
:
10355 case EXEC_OMP_CANCEL
:
10356 case EXEC_OMP_CANCELLATION_POINT
:
10357 case EXEC_OMP_CRITICAL
:
10358 case EXEC_OMP_FLUSH
:
10359 case EXEC_OMP_DISTRIBUTE
:
10360 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10361 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10362 case EXEC_OMP_DISTRIBUTE_SIMD
:
10364 case EXEC_OMP_DO_SIMD
:
10365 case EXEC_OMP_MASTER
:
10366 case EXEC_OMP_ORDERED
:
10367 case EXEC_OMP_SECTIONS
:
10368 case EXEC_OMP_SIMD
:
10369 case EXEC_OMP_SINGLE
:
10370 case EXEC_OMP_TARGET
:
10371 case EXEC_OMP_TARGET_DATA
:
10372 case EXEC_OMP_TARGET_TEAMS
:
10373 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10374 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10375 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10376 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10377 case EXEC_OMP_TARGET_UPDATE
:
10378 case EXEC_OMP_TASK
:
10379 case EXEC_OMP_TASKGROUP
:
10380 case EXEC_OMP_TASKWAIT
:
10381 case EXEC_OMP_TASKYIELD
:
10382 case EXEC_OMP_TEAMS
:
10383 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10384 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10385 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10386 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10387 case EXEC_OMP_WORKSHARE
:
10388 gfc_resolve_omp_directive (code
, ns
);
10391 case EXEC_OMP_PARALLEL
:
10392 case EXEC_OMP_PARALLEL_DO
:
10393 case EXEC_OMP_PARALLEL_DO_SIMD
:
10394 case EXEC_OMP_PARALLEL_SECTIONS
:
10395 case EXEC_OMP_PARALLEL_WORKSHARE
:
10396 omp_workshare_save
= omp_workshare_flag
;
10397 omp_workshare_flag
= 0;
10398 gfc_resolve_omp_directive (code
, ns
);
10399 omp_workshare_flag
= omp_workshare_save
;
10403 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10407 cs_base
= frame
.prev
;
10411 /* Resolve initial values and make sure they are compatible with
10415 resolve_values (gfc_symbol
*sym
)
10419 if (sym
->value
== NULL
)
10422 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10423 t
= resolve_structure_cons (sym
->value
, 1);
10425 t
= gfc_resolve_expr (sym
->value
);
10430 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10434 /* Verify any BIND(C) derived types in the namespace so we can report errors
10435 for them once, rather than for each variable declared of that type. */
10438 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10440 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10441 && derived_sym
->attr
.is_bind_c
== 1)
10442 verify_bind_c_derived_type (derived_sym
);
10448 /* Verify that any binding labels used in a given namespace do not collide
10449 with the names or binding labels of any global symbols. Multiple INTERFACE
10450 for the same procedure are permitted. */
10453 gfc_verify_binding_labels (gfc_symbol
*sym
)
10456 const char *module
;
10458 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10459 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10462 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10465 module
= sym
->module
;
10466 else if (sym
->ns
&& sym
->ns
->proc_name
10467 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10468 module
= sym
->ns
->proc_name
->name
;
10469 else if (sym
->ns
&& sym
->ns
->parent
10470 && sym
->ns
&& sym
->ns
->parent
->proc_name
10471 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10472 module
= sym
->ns
->parent
->proc_name
->name
;
10478 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10481 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10482 gsym
->where
= sym
->declared_at
;
10483 gsym
->sym_name
= sym
->name
;
10484 gsym
->binding_label
= sym
->binding_label
;
10485 gsym
->ns
= sym
->ns
;
10486 gsym
->mod_name
= module
;
10487 if (sym
->attr
.function
)
10488 gsym
->type
= GSYM_FUNCTION
;
10489 else if (sym
->attr
.subroutine
)
10490 gsym
->type
= GSYM_SUBROUTINE
;
10491 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10492 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10496 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10498 gfc_error_1 ("Variable %s with binding label %s at %L uses the same global "
10499 "identifier as entity at %L", sym
->name
,
10500 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10501 /* Clear the binding label to prevent checking multiple times. */
10502 sym
->binding_label
= NULL
;
10505 else if (sym
->attr
.flavor
== FL_VARIABLE
10506 && (strcmp (module
, gsym
->mod_name
) != 0
10507 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10509 /* This can only happen if the variable is defined in a module - if it
10510 isn't the same module, reject it. */
10511 gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses "
10512 "the same global identifier as entity at %L from module %s",
10513 sym
->name
, module
, sym
->binding_label
,
10514 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10515 sym
->binding_label
= NULL
;
10517 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10518 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10519 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10520 && sym
!= gsym
->ns
->proc_name
10521 && (module
!= gsym
->mod_name
10522 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10523 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10525 /* Print an error if the procedure is defined multiple times; we have to
10526 exclude references to the same procedure via module association or
10527 multiple checks for the same procedure. */
10528 gfc_error_1 ("Procedure %s with binding label %s at %L uses the same "
10529 "global identifier as entity at %L", sym
->name
,
10530 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10531 sym
->binding_label
= NULL
;
10536 /* Resolve an index expression. */
10539 resolve_index_expr (gfc_expr
*e
)
10541 if (!gfc_resolve_expr (e
))
10544 if (!gfc_simplify_expr (e
, 0))
10547 if (!gfc_specification_expr (e
))
10554 /* Resolve a charlen structure. */
10557 resolve_charlen (gfc_charlen
*cl
)
10560 bool saved_specification_expr
;
10566 saved_specification_expr
= specification_expr
;
10567 specification_expr
= true;
10569 if (cl
->length_from_typespec
)
10571 if (!gfc_resolve_expr (cl
->length
))
10573 specification_expr
= saved_specification_expr
;
10577 if (!gfc_simplify_expr (cl
->length
, 0))
10579 specification_expr
= saved_specification_expr
;
10586 if (!resolve_index_expr (cl
->length
))
10588 specification_expr
= saved_specification_expr
;
10593 /* "If the character length parameter value evaluates to a negative
10594 value, the length of character entities declared is zero." */
10595 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10597 if (warn_surprising
)
10598 gfc_warning_now (OPT_Wsurprising
,
10599 "CHARACTER variable at %L has negative length %d,"
10600 " the length has been set to zero",
10601 &cl
->length
->where
, i
);
10602 gfc_replace_expr (cl
->length
,
10603 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10606 /* Check that the character length is not too large. */
10607 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10608 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10609 && cl
->length
->ts
.type
== BT_INTEGER
10610 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10612 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10613 specification_expr
= saved_specification_expr
;
10617 specification_expr
= saved_specification_expr
;
10622 /* Test for non-constant shape arrays. */
10625 is_non_constant_shape_array (gfc_symbol
*sym
)
10631 not_constant
= false;
10632 if (sym
->as
!= NULL
)
10634 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10635 has not been simplified; parameter array references. Do the
10636 simplification now. */
10637 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10639 e
= sym
->as
->lower
[i
];
10640 if (e
&& (!resolve_index_expr(e
)
10641 || !gfc_is_constant_expr (e
)))
10642 not_constant
= true;
10643 e
= sym
->as
->upper
[i
];
10644 if (e
&& (!resolve_index_expr(e
)
10645 || !gfc_is_constant_expr (e
)))
10646 not_constant
= true;
10649 return not_constant
;
10652 /* Given a symbol and an initialization expression, add code to initialize
10653 the symbol to the function entry. */
10655 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10659 gfc_namespace
*ns
= sym
->ns
;
10661 /* Search for the function namespace if this is a contained
10662 function without an explicit result. */
10663 if (sym
->attr
.function
&& sym
== sym
->result
10664 && sym
->name
!= sym
->ns
->proc_name
->name
)
10666 ns
= ns
->contained
;
10667 for (;ns
; ns
= ns
->sibling
)
10668 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10674 gfc_free_expr (init
);
10678 /* Build an l-value expression for the result. */
10679 lval
= gfc_lval_expr_from_sym (sym
);
10681 /* Add the code at scope entry. */
10682 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10683 init_st
->next
= ns
->code
;
10684 ns
->code
= init_st
;
10686 /* Assign the default initializer to the l-value. */
10687 init_st
->loc
= sym
->declared_at
;
10688 init_st
->expr1
= lval
;
10689 init_st
->expr2
= init
;
10692 /* Assign the default initializer to a derived type variable or result. */
10695 apply_default_init (gfc_symbol
*sym
)
10697 gfc_expr
*init
= NULL
;
10699 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10702 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10703 init
= gfc_default_initializer (&sym
->ts
);
10705 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10708 build_init_assign (sym
, init
);
10709 sym
->attr
.referenced
= 1;
10712 /* Build an initializer for a local integer, real, complex, logical, or
10713 character variable, based on the command line flags finit-local-zero,
10714 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10715 null if the symbol should not have a default initialization. */
10717 build_default_init_expr (gfc_symbol
*sym
)
10720 gfc_expr
*init_expr
;
10723 /* These symbols should never have a default initialization. */
10724 if (sym
->attr
.allocatable
10725 || sym
->attr
.external
10727 || sym
->attr
.pointer
10728 || sym
->attr
.in_equivalence
10729 || sym
->attr
.in_common
10732 || sym
->attr
.cray_pointee
10733 || sym
->attr
.cray_pointer
10737 /* Now we'll try to build an initializer expression. */
10738 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10739 &sym
->declared_at
);
10741 /* We will only initialize integers, reals, complex, logicals, and
10742 characters, and only if the corresponding command-line flags
10743 were set. Otherwise, we free init_expr and return null. */
10744 switch (sym
->ts
.type
)
10747 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10748 mpz_set_si (init_expr
->value
.integer
,
10749 gfc_option
.flag_init_integer_value
);
10752 gfc_free_expr (init_expr
);
10758 switch (flag_init_real
)
10760 case GFC_INIT_REAL_SNAN
:
10761 init_expr
->is_snan
= 1;
10762 /* Fall through. */
10763 case GFC_INIT_REAL_NAN
:
10764 mpfr_set_nan (init_expr
->value
.real
);
10767 case GFC_INIT_REAL_INF
:
10768 mpfr_set_inf (init_expr
->value
.real
, 1);
10771 case GFC_INIT_REAL_NEG_INF
:
10772 mpfr_set_inf (init_expr
->value
.real
, -1);
10775 case GFC_INIT_REAL_ZERO
:
10776 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10780 gfc_free_expr (init_expr
);
10787 switch (flag_init_real
)
10789 case GFC_INIT_REAL_SNAN
:
10790 init_expr
->is_snan
= 1;
10791 /* Fall through. */
10792 case GFC_INIT_REAL_NAN
:
10793 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10794 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10797 case GFC_INIT_REAL_INF
:
10798 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10799 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10802 case GFC_INIT_REAL_NEG_INF
:
10803 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10804 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10807 case GFC_INIT_REAL_ZERO
:
10808 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10812 gfc_free_expr (init_expr
);
10819 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10820 init_expr
->value
.logical
= 0;
10821 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10822 init_expr
->value
.logical
= 1;
10825 gfc_free_expr (init_expr
);
10831 /* For characters, the length must be constant in order to
10832 create a default initializer. */
10833 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10834 && sym
->ts
.u
.cl
->length
10835 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10837 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10838 init_expr
->value
.character
.length
= char_len
;
10839 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10840 for (i
= 0; i
< char_len
; i
++)
10841 init_expr
->value
.character
.string
[i
]
10842 = (unsigned char) gfc_option
.flag_init_character_value
;
10846 gfc_free_expr (init_expr
);
10849 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10850 && sym
->ts
.u
.cl
->length
&& flag_max_stack_var_size
!= 0)
10852 gfc_actual_arglist
*arg
;
10853 init_expr
= gfc_get_expr ();
10854 init_expr
->where
= sym
->declared_at
;
10855 init_expr
->ts
= sym
->ts
;
10856 init_expr
->expr_type
= EXPR_FUNCTION
;
10857 init_expr
->value
.function
.isym
=
10858 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10859 init_expr
->value
.function
.name
= "repeat";
10860 arg
= gfc_get_actual_arglist ();
10861 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10863 arg
->expr
->value
.character
.string
[0]
10864 = gfc_option
.flag_init_character_value
;
10865 arg
->next
= gfc_get_actual_arglist ();
10866 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10867 init_expr
->value
.function
.actual
= arg
;
10872 gfc_free_expr (init_expr
);
10878 /* Add an initialization expression to a local variable. */
10880 apply_default_init_local (gfc_symbol
*sym
)
10882 gfc_expr
*init
= NULL
;
10884 /* The symbol should be a variable or a function return value. */
10885 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10886 || (sym
->attr
.function
&& sym
->result
!= sym
))
10889 /* Try to build the initializer expression. If we can't initialize
10890 this symbol, then init will be NULL. */
10891 init
= build_default_init_expr (sym
);
10895 /* For saved variables, we don't want to add an initializer at function
10896 entry, so we just add a static initializer. Note that automatic variables
10897 are stack allocated even with -fno-automatic; we have also to exclude
10898 result variable, which are also nonstatic. */
10899 if (sym
->attr
.save
|| sym
->ns
->save_all
10900 || (flag_max_stack_var_size
== 0 && !sym
->attr
.result
10901 && !sym
->ns
->proc_name
->attr
.recursive
10902 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10904 /* Don't clobber an existing initializer! */
10905 gcc_assert (sym
->value
== NULL
);
10910 build_init_assign (sym
, init
);
10914 /* Resolution of common features of flavors variable and procedure. */
10917 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10919 gfc_array_spec
*as
;
10921 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10922 as
= CLASS_DATA (sym
)->as
;
10926 /* Constraints on deferred shape variable. */
10927 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10929 bool pointer
, allocatable
, dimension
;
10931 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10933 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10934 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10935 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10939 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10940 allocatable
= sym
->attr
.allocatable
;
10941 dimension
= sym
->attr
.dimension
;
10946 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10948 gfc_error ("Allocatable array %qs at %L must have a deferred "
10949 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10952 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10953 "%qs at %L may not be ALLOCATABLE",
10954 sym
->name
, &sym
->declared_at
))
10958 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10960 gfc_error ("Array pointer %qs at %L must have a deferred shape or "
10961 "assumed rank", sym
->name
, &sym
->declared_at
);
10967 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10968 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10970 gfc_error ("Array %qs at %L cannot have a deferred shape",
10971 sym
->name
, &sym
->declared_at
);
10976 /* Constraints on polymorphic variables. */
10977 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10980 if (sym
->attr
.class_ok
10981 && !sym
->attr
.select_type_temporary
10982 && !UNLIMITED_POLY (sym
)
10983 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10985 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible",
10986 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10987 &sym
->declared_at
);
10992 /* Assume that use associated symbols were checked in the module ns.
10993 Class-variables that are associate-names are also something special
10994 and excepted from the test. */
10995 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10997 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable "
10998 "or pointer", sym
->name
, &sym
->declared_at
);
11007 /* Additional checks for symbols with flavor variable and derived
11008 type. To be called from resolve_fl_variable. */
11011 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11013 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11015 /* Check to see if a derived type is blocked from being host
11016 associated by the presence of another class I symbol in the same
11017 namespace. 14.6.1.3 of the standard and the discussion on
11018 comp.lang.fortran. */
11019 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11020 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11023 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11024 if (s
&& s
->attr
.generic
)
11025 s
= gfc_find_dt_in_generic (s
);
11026 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
11028 gfc_error_1 ("The type '%s' cannot be host associated at %L "
11029 "because it is blocked by an incompatible object "
11030 "of the same name declared at %L",
11031 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11037 /* 4th constraint in section 11.3: "If an object of a type for which
11038 component-initialization is specified (R429) appears in the
11039 specification-part of a module and does not have the ALLOCATABLE
11040 or POINTER attribute, the object shall have the SAVE attribute."
11042 The check for initializers is performed with
11043 gfc_has_default_initializer because gfc_default_initializer generates
11044 a hidden default for allocatable components. */
11045 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11046 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11047 && !sym
->ns
->save_all
&& !sym
->attr
.save
11048 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11049 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11050 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
11051 "%qs at %L, needed due to the default "
11052 "initialization", sym
->name
, &sym
->declared_at
))
11055 /* Assign default initializer. */
11056 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11057 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11059 sym
->value
= gfc_default_initializer (&sym
->ts
);
11066 /* Resolve symbols with flavor variable. */
11069 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11071 int no_init_flag
, automatic_flag
;
11073 const char *auto_save_msg
;
11074 bool saved_specification_expr
;
11076 auto_save_msg
= "Automatic object %qs at %L cannot have the "
11079 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11082 /* Set this flag to check that variables are parameters of all entries.
11083 This check is effected by the call to gfc_resolve_expr through
11084 is_non_constant_shape_array. */
11085 saved_specification_expr
= specification_expr
;
11086 specification_expr
= true;
11088 if (sym
->ns
->proc_name
11089 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11090 || sym
->ns
->proc_name
->attr
.is_main_program
)
11091 && !sym
->attr
.use_assoc
11092 && !sym
->attr
.allocatable
11093 && !sym
->attr
.pointer
11094 && is_non_constant_shape_array (sym
))
11096 /* The shape of a main program or module array needs to be
11098 gfc_error ("The module or main program array '%s' at %L must "
11099 "have constant shape", sym
->name
, &sym
->declared_at
);
11100 specification_expr
= saved_specification_expr
;
11104 /* Constraints on deferred type parameter. */
11105 if (sym
->ts
.deferred
11106 && !(sym
->attr
.pointer
11107 || sym
->attr
.allocatable
11108 || sym
->attr
.omp_udr_artificial_var
))
11110 gfc_error ("Entity %qs at %L has a deferred type parameter and "
11111 "requires either the pointer or allocatable attribute",
11112 sym
->name
, &sym
->declared_at
);
11113 specification_expr
= saved_specification_expr
;
11117 if (sym
->ts
.type
== BT_CHARACTER
)
11119 /* Make sure that character string variables with assumed length are
11120 dummy arguments. */
11121 e
= sym
->ts
.u
.cl
->length
;
11122 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11123 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11124 && !sym
->attr
.omp_udr_artificial_var
)
11126 gfc_error ("Entity with assumed character length at %L must be a "
11127 "dummy argument or a PARAMETER", &sym
->declared_at
);
11128 specification_expr
= saved_specification_expr
;
11132 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11134 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11135 specification_expr
= saved_specification_expr
;
11139 if (!gfc_is_constant_expr (e
)
11140 && !(e
->expr_type
== EXPR_VARIABLE
11141 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11143 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11144 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11145 || sym
->ns
->proc_name
->attr
.is_main_program
))
11147 gfc_error ("'%s' at %L must have constant character length "
11148 "in this context", sym
->name
, &sym
->declared_at
);
11149 specification_expr
= saved_specification_expr
;
11152 if (sym
->attr
.in_common
)
11154 gfc_error ("COMMON variable %qs at %L must have constant "
11155 "character length", sym
->name
, &sym
->declared_at
);
11156 specification_expr
= saved_specification_expr
;
11162 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11163 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11165 /* Determine if the symbol may not have an initializer. */
11166 no_init_flag
= automatic_flag
= 0;
11167 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11168 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11170 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11171 && is_non_constant_shape_array (sym
))
11173 no_init_flag
= automatic_flag
= 1;
11175 /* Also, they must not have the SAVE attribute.
11176 SAVE_IMPLICIT is checked below. */
11177 if (sym
->as
&& sym
->attr
.codimension
)
11179 int corank
= sym
->as
->corank
;
11180 sym
->as
->corank
= 0;
11181 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11182 sym
->as
->corank
= corank
;
11184 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11186 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11187 specification_expr
= saved_specification_expr
;
11192 /* Ensure that any initializer is simplified. */
11194 gfc_simplify_expr (sym
->value
, 1);
11196 /* Reject illegal initializers. */
11197 if (!sym
->mark
&& sym
->value
)
11199 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11200 && CLASS_DATA (sym
)->attr
.allocatable
))
11201 gfc_error ("Allocatable %qs at %L cannot have an initializer",
11202 sym
->name
, &sym
->declared_at
);
11203 else if (sym
->attr
.external
)
11204 gfc_error ("External %qs at %L cannot have an initializer",
11205 sym
->name
, &sym
->declared_at
);
11206 else if (sym
->attr
.dummy
11207 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11208 gfc_error ("Dummy %qs at %L cannot have an initializer",
11209 sym
->name
, &sym
->declared_at
);
11210 else if (sym
->attr
.intrinsic
)
11211 gfc_error ("Intrinsic %qs at %L cannot have an initializer",
11212 sym
->name
, &sym
->declared_at
);
11213 else if (sym
->attr
.result
)
11214 gfc_error ("Function result %qs at %L cannot have an initializer",
11215 sym
->name
, &sym
->declared_at
);
11216 else if (automatic_flag
)
11217 gfc_error ("Automatic array %qs at %L cannot have an initializer",
11218 sym
->name
, &sym
->declared_at
);
11220 goto no_init_error
;
11221 specification_expr
= saved_specification_expr
;
11226 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11228 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11229 specification_expr
= saved_specification_expr
;
11233 specification_expr
= saved_specification_expr
;
11238 /* Resolve a procedure. */
11241 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11243 gfc_formal_arglist
*arg
;
11245 if (sym
->attr
.function
11246 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11249 if (sym
->ts
.type
== BT_CHARACTER
)
11251 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11253 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11254 && !resolve_charlen (cl
))
11257 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11258 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11260 gfc_error ("Character-valued statement function %qs at %L must "
11261 "have constant length", sym
->name
, &sym
->declared_at
);
11266 /* Ensure that derived type for are not of a private type. Internal
11267 module procedures are excluded by 2.2.3.3 - i.e., they are not
11268 externally accessible and can access all the objects accessible in
11270 if (!(sym
->ns
->parent
11271 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11272 && gfc_check_symbol_access (sym
))
11274 gfc_interface
*iface
;
11276 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11279 && arg
->sym
->ts
.type
== BT_DERIVED
11280 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11281 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11282 && !gfc_notify_std (GFC_STD_F2003
, "%qs is of a PRIVATE type "
11283 "and cannot be a dummy argument"
11284 " of %qs, which is PUBLIC at %L",
11285 arg
->sym
->name
, sym
->name
,
11286 &sym
->declared_at
))
11288 /* Stop this message from recurring. */
11289 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11294 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11295 PRIVATE to the containing module. */
11296 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11298 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11301 && arg
->sym
->ts
.type
== BT_DERIVED
11302 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11303 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11304 && !gfc_notify_std (GFC_STD_F2003
, "Procedure %qs in "
11305 "PUBLIC interface %qs at %L "
11306 "takes dummy arguments of %qs which "
11307 "is PRIVATE", iface
->sym
->name
,
11308 sym
->name
, &iface
->sym
->declared_at
,
11309 gfc_typename(&arg
->sym
->ts
)))
11311 /* Stop this message from recurring. */
11312 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11319 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11320 && !sym
->attr
.proc_pointer
)
11322 gfc_error ("Function %qs at %L cannot have an initializer",
11323 sym
->name
, &sym
->declared_at
);
11327 /* An external symbol may not have an initializer because it is taken to be
11328 a procedure. Exception: Procedure Pointers. */
11329 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11331 gfc_error ("External object %qs at %L may not have an initializer",
11332 sym
->name
, &sym
->declared_at
);
11336 /* An elemental function is required to return a scalar 12.7.1 */
11337 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11339 gfc_error ("ELEMENTAL function %qs at %L must have a scalar "
11340 "result", sym
->name
, &sym
->declared_at
);
11341 /* Reset so that the error only occurs once. */
11342 sym
->attr
.elemental
= 0;
11346 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11347 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11349 gfc_error ("Statement function %qs at %L may not have pointer or "
11350 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11354 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11355 char-len-param shall not be array-valued, pointer-valued, recursive
11356 or pure. ....snip... A character value of * may only be used in the
11357 following ways: (i) Dummy arg of procedure - dummy associates with
11358 actual length; (ii) To declare a named constant; or (iii) External
11359 function - but length must be declared in calling scoping unit. */
11360 if (sym
->attr
.function
11361 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11362 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11364 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11365 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11367 if (sym
->as
&& sym
->as
->rank
)
11368 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11369 "array-valued", sym
->name
, &sym
->declared_at
);
11371 if (sym
->attr
.pointer
)
11372 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11373 "pointer-valued", sym
->name
, &sym
->declared_at
);
11375 if (sym
->attr
.pure
)
11376 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11377 "pure", sym
->name
, &sym
->declared_at
);
11379 if (sym
->attr
.recursive
)
11380 gfc_error ("CHARACTER(*) function %qs at %L cannot be "
11381 "recursive", sym
->name
, &sym
->declared_at
);
11386 /* Appendix B.2 of the standard. Contained functions give an
11387 error anyway. Deferred character length is an F2003 feature.
11388 Don't warn on intrinsic conversion functions, which start
11389 with two underscores. */
11390 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11391 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11392 gfc_notify_std (GFC_STD_F95_OBS
,
11393 "CHARACTER(*) function %qs at %L",
11394 sym
->name
, &sym
->declared_at
);
11397 /* F2008, C1218. */
11398 if (sym
->attr
.elemental
)
11400 if (sym
->attr
.proc_pointer
)
11402 gfc_error ("Procedure pointer %qs at %L shall not be elemental",
11403 sym
->name
, &sym
->declared_at
);
11406 if (sym
->attr
.dummy
)
11408 gfc_error ("Dummy procedure %qs at %L shall not be elemental",
11409 sym
->name
, &sym
->declared_at
);
11414 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11416 gfc_formal_arglist
*curr_arg
;
11417 int has_non_interop_arg
= 0;
11419 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11420 sym
->common_block
))
11422 /* Clear these to prevent looking at them again if there was an
11424 sym
->attr
.is_bind_c
= 0;
11425 sym
->attr
.is_c_interop
= 0;
11426 sym
->ts
.is_c_interop
= 0;
11430 /* So far, no errors have been found. */
11431 sym
->attr
.is_c_interop
= 1;
11432 sym
->ts
.is_c_interop
= 1;
11435 curr_arg
= gfc_sym_get_dummy_args (sym
);
11436 while (curr_arg
!= NULL
)
11438 /* Skip implicitly typed dummy args here. */
11439 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11440 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11441 /* If something is found to fail, record the fact so we
11442 can mark the symbol for the procedure as not being
11443 BIND(C) to try and prevent multiple errors being
11445 has_non_interop_arg
= 1;
11447 curr_arg
= curr_arg
->next
;
11450 /* See if any of the arguments were not interoperable and if so, clear
11451 the procedure symbol to prevent duplicate error messages. */
11452 if (has_non_interop_arg
!= 0)
11454 sym
->attr
.is_c_interop
= 0;
11455 sym
->ts
.is_c_interop
= 0;
11456 sym
->attr
.is_bind_c
= 0;
11460 if (!sym
->attr
.proc_pointer
)
11462 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11464 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11465 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11468 if (sym
->attr
.intent
)
11470 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11471 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11474 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11476 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11477 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11480 if (sym
->attr
.external
&& sym
->attr
.function
11481 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11482 || sym
->attr
.contained
))
11484 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11485 "in %qs at %L", sym
->name
, &sym
->declared_at
);
11488 if (strcmp ("ppr@", sym
->name
) == 0)
11490 gfc_error ("Procedure pointer result %qs at %L "
11491 "is missing the pointer attribute",
11492 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11501 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11502 been defined and we now know their defined arguments, check that they fulfill
11503 the requirements of the standard for procedures used as finalizers. */
11506 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11508 gfc_finalizer
* list
;
11509 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11510 bool result
= true;
11511 bool seen_scalar
= false;
11514 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
11517 gfc_resolve_finalizers (parent
, finalizable
);
11519 /* Return early when not finalizable. Additionally, ensure that derived-type
11520 components have a their finalizables resolved. */
11521 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11523 bool has_final
= false;
11524 for (c
= derived
->components
; c
; c
= c
->next
)
11525 if (c
->ts
.type
== BT_DERIVED
11526 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11528 bool has_final2
= false;
11529 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11530 return false; /* Error. */
11531 has_final
= has_final
|| has_final2
;
11536 *finalizable
= false;
11541 /* Walk over the list of finalizer-procedures, check them, and if any one
11542 does not fit in with the standard's definition, print an error and remove
11543 it from the list. */
11544 prev_link
= &derived
->f2k_derived
->finalizers
;
11545 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11547 gfc_formal_arglist
*dummy_args
;
11552 /* Skip this finalizer if we already resolved it. */
11553 if (list
->proc_tree
)
11555 prev_link
= &(list
->next
);
11559 /* Check this exists and is a SUBROUTINE. */
11560 if (!list
->proc_sym
->attr
.subroutine
)
11562 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE",
11563 list
->proc_sym
->name
, &list
->where
);
11567 /* We should have exactly one argument. */
11568 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11569 if (!dummy_args
|| dummy_args
->next
)
11571 gfc_error ("FINAL procedure at %L must have exactly one argument",
11575 arg
= dummy_args
->sym
;
11577 /* This argument must be of our type. */
11578 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11580 gfc_error ("Argument of FINAL procedure at %L must be of type %qs",
11581 &arg
->declared_at
, derived
->name
);
11585 /* It must neither be a pointer nor allocatable nor optional. */
11586 if (arg
->attr
.pointer
)
11588 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11589 &arg
->declared_at
);
11592 if (arg
->attr
.allocatable
)
11594 gfc_error ("Argument of FINAL procedure at %L must not be"
11595 " ALLOCATABLE", &arg
->declared_at
);
11598 if (arg
->attr
.optional
)
11600 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11601 &arg
->declared_at
);
11605 /* It must not be INTENT(OUT). */
11606 if (arg
->attr
.intent
== INTENT_OUT
)
11608 gfc_error ("Argument of FINAL procedure at %L must not be"
11609 " INTENT(OUT)", &arg
->declared_at
);
11613 /* Warn if the procedure is non-scalar and not assumed shape. */
11614 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11615 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11616 gfc_warning (OPT_Wsurprising
,
11617 "Non-scalar FINAL procedure at %L should have assumed"
11618 " shape argument", &arg
->declared_at
);
11620 /* Check that it does not match in kind and rank with a FINAL procedure
11621 defined earlier. To really loop over the *earlier* declarations,
11622 we need to walk the tail of the list as new ones were pushed at the
11624 /* TODO: Handle kind parameters once they are implemented. */
11625 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11626 for (i
= list
->next
; i
; i
= i
->next
)
11628 gfc_formal_arglist
*dummy_args
;
11630 /* Argument list might be empty; that is an error signalled earlier,
11631 but we nevertheless continued resolving. */
11632 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11635 gfc_symbol
* i_arg
= dummy_args
->sym
;
11636 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11637 if (i_rank
== my_rank
)
11639 gfc_error ("FINAL procedure %qs declared at %L has the same"
11640 " rank (%d) as %qs",
11641 list
->proc_sym
->name
, &list
->where
, my_rank
,
11642 i
->proc_sym
->name
);
11648 /* Is this the/a scalar finalizer procedure? */
11649 if (!arg
->as
|| arg
->as
->rank
== 0)
11650 seen_scalar
= true;
11652 /* Find the symtree for this procedure. */
11653 gcc_assert (!list
->proc_tree
);
11654 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11656 prev_link
= &list
->next
;
11659 /* Remove wrong nodes immediately from the list so we don't risk any
11660 troubles in the future when they might fail later expectations. */
11663 *prev_link
= list
->next
;
11664 gfc_free_finalizer (i
);
11668 if (result
== false)
11671 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11672 were nodes in the list, must have been for arrays. It is surely a good
11673 idea to have a scalar version there if there's something to finalize. */
11674 if (warn_surprising
&& result
&& !seen_scalar
)
11675 gfc_warning (OPT_Wsurprising
,
11676 "Only array FINAL procedures declared for derived type %qs"
11677 " defined at %L, suggest also scalar one",
11678 derived
->name
, &derived
->declared_at
);
11680 vtab
= gfc_find_derived_vtab (derived
);
11681 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11682 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11685 *finalizable
= true;
11691 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11694 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11695 const char* generic_name
, locus where
)
11697 gfc_symbol
*sym1
, *sym2
;
11698 const char *pass1
, *pass2
;
11699 gfc_formal_arglist
*dummy_args
;
11701 gcc_assert (t1
->specific
&& t2
->specific
);
11702 gcc_assert (!t1
->specific
->is_generic
);
11703 gcc_assert (!t2
->specific
->is_generic
);
11704 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11706 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11707 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11712 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11713 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11714 || sym1
->attr
.function
!= sym2
->attr
.function
)
11716 gfc_error ("%qs and %qs can't be mixed FUNCTION/SUBROUTINE for"
11717 " GENERIC %qs at %L",
11718 sym1
->name
, sym2
->name
, generic_name
, &where
);
11722 /* Determine PASS arguments. */
11723 if (t1
->specific
->nopass
)
11725 else if (t1
->specific
->pass_arg
)
11726 pass1
= t1
->specific
->pass_arg
;
11729 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
11731 pass1
= dummy_args
->sym
->name
;
11735 if (t2
->specific
->nopass
)
11737 else if (t2
->specific
->pass_arg
)
11738 pass2
= t2
->specific
->pass_arg
;
11741 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
11743 pass2
= dummy_args
->sym
->name
;
11748 /* Compare the interfaces. */
11749 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11750 NULL
, 0, pass1
, pass2
))
11752 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous",
11753 sym1
->name
, sym2
->name
, generic_name
, &where
);
11761 /* Worker function for resolving a generic procedure binding; this is used to
11762 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11764 The difference between those cases is finding possible inherited bindings
11765 that are overridden, as one has to look for them in tb_sym_root,
11766 tb_uop_root or tb_op, respectively. Thus the caller must already find
11767 the super-type and set p->overridden correctly. */
11770 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11771 gfc_typebound_proc
* p
, const char* name
)
11773 gfc_tbp_generic
* target
;
11774 gfc_symtree
* first_target
;
11775 gfc_symtree
* inherited
;
11777 gcc_assert (p
&& p
->is_generic
);
11779 /* Try to find the specific bindings for the symtrees in our target-list. */
11780 gcc_assert (p
->u
.generic
);
11781 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11782 if (!target
->specific
)
11784 gfc_typebound_proc
* overridden_tbp
;
11785 gfc_tbp_generic
* g
;
11786 const char* target_name
;
11788 target_name
= target
->specific_st
->name
;
11790 /* Defined for this type directly. */
11791 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11793 target
->specific
= target
->specific_st
->n
.tb
;
11794 goto specific_found
;
11797 /* Look for an inherited specific binding. */
11800 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11805 gcc_assert (inherited
->n
.tb
);
11806 target
->specific
= inherited
->n
.tb
;
11807 goto specific_found
;
11811 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs"
11812 " at %L", target_name
, name
, &p
->where
);
11815 /* Once we've found the specific binding, check it is not ambiguous with
11816 other specifics already found or inherited for the same GENERIC. */
11818 gcc_assert (target
->specific
);
11820 /* This must really be a specific binding! */
11821 if (target
->specific
->is_generic
)
11823 gfc_error ("GENERIC %qs at %L must target a specific binding,"
11824 " %qs is GENERIC, too", name
, &p
->where
, target_name
);
11828 /* Check those already resolved on this type directly. */
11829 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11830 if (g
!= target
&& g
->specific
11831 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11834 /* Check for ambiguity with inherited specific targets. */
11835 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11836 overridden_tbp
= overridden_tbp
->overridden
)
11837 if (overridden_tbp
->is_generic
)
11839 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11841 gcc_assert (g
->specific
);
11842 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11848 /* If we attempt to "overwrite" a specific binding, this is an error. */
11849 if (p
->overridden
&& !p
->overridden
->is_generic
)
11851 gfc_error ("GENERIC %qs at %L can't overwrite specific binding with"
11852 " the same name", name
, &p
->where
);
11856 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11857 all must have the same attributes here. */
11858 first_target
= p
->u
.generic
->specific
->u
.specific
;
11859 gcc_assert (first_target
);
11860 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11861 p
->function
= first_target
->n
.sym
->attr
.function
;
11867 /* Resolve a GENERIC procedure binding for a derived type. */
11870 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11872 gfc_symbol
* super_type
;
11874 /* Find the overridden binding if any. */
11875 st
->n
.tb
->overridden
= NULL
;
11876 super_type
= gfc_get_derived_super_type (derived
);
11879 gfc_symtree
* overridden
;
11880 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11883 if (overridden
&& overridden
->n
.tb
)
11884 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11887 /* Resolve using worker function. */
11888 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11892 /* Retrieve the target-procedure of an operator binding and do some checks in
11893 common for intrinsic and user-defined type-bound operators. */
11896 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11898 gfc_symbol
* target_proc
;
11900 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11901 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11902 gcc_assert (target_proc
);
11904 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11905 if (target
->specific
->nopass
)
11907 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11911 return target_proc
;
11915 /* Resolve a type-bound intrinsic operator. */
11918 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11919 gfc_typebound_proc
* p
)
11921 gfc_symbol
* super_type
;
11922 gfc_tbp_generic
* target
;
11924 /* If there's already an error here, do nothing (but don't fail again). */
11928 /* Operators should always be GENERIC bindings. */
11929 gcc_assert (p
->is_generic
);
11931 /* Look for an overridden binding. */
11932 super_type
= gfc_get_derived_super_type (derived
);
11933 if (super_type
&& super_type
->f2k_derived
)
11934 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11937 p
->overridden
= NULL
;
11939 /* Resolve general GENERIC properties using worker function. */
11940 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11943 /* Check the targets to be procedures of correct interface. */
11944 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11946 gfc_symbol
* target_proc
;
11948 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11952 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11955 /* Add target to non-typebound operator list. */
11956 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11957 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11959 gfc_interface
*head
, *intr
;
11960 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11962 head
= derived
->ns
->op
[op
];
11963 intr
= gfc_get_interface ();
11964 intr
->sym
= target_proc
;
11965 intr
->where
= p
->where
;
11967 derived
->ns
->op
[op
] = intr
;
11979 /* Resolve a type-bound user operator (tree-walker callback). */
11981 static gfc_symbol
* resolve_bindings_derived
;
11982 static bool resolve_bindings_result
;
11984 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11987 resolve_typebound_user_op (gfc_symtree
* stree
)
11989 gfc_symbol
* super_type
;
11990 gfc_tbp_generic
* target
;
11992 gcc_assert (stree
&& stree
->n
.tb
);
11994 if (stree
->n
.tb
->error
)
11997 /* Operators should always be GENERIC bindings. */
11998 gcc_assert (stree
->n
.tb
->is_generic
);
12000 /* Find overridden procedure, if any. */
12001 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12002 if (super_type
&& super_type
->f2k_derived
)
12004 gfc_symtree
* overridden
;
12005 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12006 stree
->name
, true, NULL
);
12008 if (overridden
&& overridden
->n
.tb
)
12009 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12012 stree
->n
.tb
->overridden
= NULL
;
12014 /* Resolve basically using worker function. */
12015 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
12018 /* Check the targets to be functions of correct interface. */
12019 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12021 gfc_symbol
* target_proc
;
12023 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12027 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
12034 resolve_bindings_result
= false;
12035 stree
->n
.tb
->error
= 1;
12039 /* Resolve the type-bound procedures for a derived type. */
12042 resolve_typebound_procedure (gfc_symtree
* stree
)
12046 gfc_symbol
* me_arg
;
12047 gfc_symbol
* super_type
;
12048 gfc_component
* comp
;
12050 gcc_assert (stree
);
12052 /* Undefined specific symbol from GENERIC target definition. */
12056 if (stree
->n
.tb
->error
)
12059 /* If this is a GENERIC binding, use that routine. */
12060 if (stree
->n
.tb
->is_generic
)
12062 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
12067 /* Get the target-procedure to check it. */
12068 gcc_assert (!stree
->n
.tb
->is_generic
);
12069 gcc_assert (stree
->n
.tb
->u
.specific
);
12070 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12071 where
= stree
->n
.tb
->where
;
12073 /* Default access should already be resolved from the parser. */
12074 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12076 if (stree
->n
.tb
->deferred
)
12078 if (!check_proc_interface (proc
, &where
))
12083 /* Check for F08:C465. */
12084 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12085 || (proc
->attr
.proc
!= PROC_MODULE
12086 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12087 || proc
->attr
.abstract
)
12089 gfc_error ("%qs must be a module procedure or an external procedure with"
12090 " an explicit interface at %L", proc
->name
, &where
);
12095 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12096 stree
->n
.tb
->function
= proc
->attr
.function
;
12098 /* Find the super-type of the current derived type. We could do this once and
12099 store in a global if speed is needed, but as long as not I believe this is
12100 more readable and clearer. */
12101 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12103 /* If PASS, resolve and check arguments if not already resolved / loaded
12104 from a .mod file. */
12105 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12107 gfc_formal_arglist
*dummy_args
;
12109 dummy_args
= gfc_sym_get_dummy_args (proc
);
12110 if (stree
->n
.tb
->pass_arg
)
12112 gfc_formal_arglist
*i
;
12114 /* If an explicit passing argument name is given, walk the arg-list
12115 and look for it. */
12118 stree
->n
.tb
->pass_arg_num
= 1;
12119 for (i
= dummy_args
; i
; i
= i
->next
)
12121 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12126 ++stree
->n
.tb
->pass_arg_num
;
12131 gfc_error ("Procedure %qs with PASS(%s) at %L has no"
12133 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12134 stree
->n
.tb
->pass_arg
);
12140 /* Otherwise, take the first one; there should in fact be at least
12142 stree
->n
.tb
->pass_arg_num
= 1;
12145 gfc_error ("Procedure %qs with PASS at %L must have at"
12146 " least one argument", proc
->name
, &where
);
12149 me_arg
= dummy_args
->sym
;
12152 /* Now check that the argument-type matches and the passed-object
12153 dummy argument is generally fine. */
12155 gcc_assert (me_arg
);
12157 if (me_arg
->ts
.type
!= BT_CLASS
)
12159 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12160 " at %L", proc
->name
, &where
);
12164 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12165 != resolve_bindings_derived
)
12167 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12168 " the derived-type %qs", me_arg
->name
, proc
->name
,
12169 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12173 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12174 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12176 gfc_error ("Passed-object dummy argument of %qs at %L must be"
12177 " scalar", proc
->name
, &where
);
12180 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12182 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12183 " be ALLOCATABLE", proc
->name
, &where
);
12186 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12188 gfc_error ("Passed-object dummy argument of %qs at %L must not"
12189 " be POINTER", proc
->name
, &where
);
12194 /* If we are extending some type, check that we don't override a procedure
12195 flagged NON_OVERRIDABLE. */
12196 stree
->n
.tb
->overridden
= NULL
;
12199 gfc_symtree
* overridden
;
12200 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12201 stree
->name
, true, NULL
);
12205 if (overridden
->n
.tb
)
12206 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12208 if (!gfc_check_typebound_override (stree
, overridden
))
12213 /* See if there's a name collision with a component directly in this type. */
12214 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12215 if (!strcmp (comp
->name
, stree
->name
))
12217 gfc_error ("Procedure %qs at %L has the same name as a component of"
12219 stree
->name
, &where
, resolve_bindings_derived
->name
);
12223 /* Try to find a name collision with an inherited component. */
12224 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12226 gfc_error ("Procedure %qs at %L has the same name as an inherited"
12227 " component of %qs",
12228 stree
->name
, &where
, resolve_bindings_derived
->name
);
12232 stree
->n
.tb
->error
= 0;
12236 resolve_bindings_result
= false;
12237 stree
->n
.tb
->error
= 1;
12242 resolve_typebound_procedures (gfc_symbol
* derived
)
12245 gfc_symbol
* super_type
;
12247 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12250 super_type
= gfc_get_derived_super_type (derived
);
12252 resolve_symbol (super_type
);
12254 resolve_bindings_derived
= derived
;
12255 resolve_bindings_result
= true;
12257 if (derived
->f2k_derived
->tb_sym_root
)
12258 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12259 &resolve_typebound_procedure
);
12261 if (derived
->f2k_derived
->tb_uop_root
)
12262 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12263 &resolve_typebound_user_op
);
12265 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12267 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12268 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12269 (gfc_intrinsic_op
)op
, p
))
12270 resolve_bindings_result
= false;
12273 return resolve_bindings_result
;
12277 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12278 to give all identical derived types the same backend_decl. */
12280 add_dt_to_dt_list (gfc_symbol
*derived
)
12282 gfc_dt_list
*dt_list
;
12284 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12285 if (derived
== dt_list
->derived
)
12288 dt_list
= gfc_get_dt_list ();
12289 dt_list
->next
= gfc_derived_types
;
12290 dt_list
->derived
= derived
;
12291 gfc_derived_types
= dt_list
;
12295 /* Ensure that a derived-type is really not abstract, meaning that every
12296 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12299 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12304 if (!ensure_not_abstract_walker (sub
, st
->left
))
12306 if (!ensure_not_abstract_walker (sub
, st
->right
))
12309 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12311 gfc_symtree
* overriding
;
12312 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12315 gcc_assert (overriding
->n
.tb
);
12316 if (overriding
->n
.tb
->deferred
)
12318 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because"
12319 " %qs is DEFERRED and not overridden",
12320 sub
->name
, &sub
->declared_at
, st
->name
);
12329 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12331 /* The algorithm used here is to recursively travel up the ancestry of sub
12332 and for each ancestor-type, check all bindings. If any of them is
12333 DEFERRED, look it up starting from sub and see if the found (overriding)
12334 binding is not DEFERRED.
12335 This is not the most efficient way to do this, but it should be ok and is
12336 clearer than something sophisticated. */
12338 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12340 if (!ancestor
->attr
.abstract
)
12343 /* Walk bindings of this ancestor. */
12344 if (ancestor
->f2k_derived
)
12347 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12352 /* Find next ancestor type and recurse on it. */
12353 ancestor
= gfc_get_derived_super_type (ancestor
);
12355 return ensure_not_abstract (sub
, ancestor
);
12361 /* This check for typebound defined assignments is done recursively
12362 since the order in which derived types are resolved is not always in
12363 order of the declarations. */
12366 check_defined_assignments (gfc_symbol
*derived
)
12370 for (c
= derived
->components
; c
; c
= c
->next
)
12372 if (c
->ts
.type
!= BT_DERIVED
12374 || c
->attr
.allocatable
12375 || c
->attr
.proc_pointer_comp
12376 || c
->attr
.class_pointer
12377 || c
->attr
.proc_pointer
)
12380 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12381 || (c
->ts
.u
.derived
->f2k_derived
12382 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12384 derived
->attr
.defined_assign_comp
= 1;
12388 check_defined_assignments (c
->ts
.u
.derived
);
12389 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12391 derived
->attr
.defined_assign_comp
= 1;
12398 /* Resolve the components of a derived type. This does not have to wait until
12399 resolution stage, but can be done as soon as the dt declaration has been
12403 resolve_fl_derived0 (gfc_symbol
*sym
)
12405 gfc_symbol
* super_type
;
12408 if (sym
->attr
.unlimited_polymorphic
)
12411 super_type
= gfc_get_derived_super_type (sym
);
12414 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12416 gfc_error ("As extending type %qs at %L has a coarray component, "
12417 "parent type %qs shall also have one", sym
->name
,
12418 &sym
->declared_at
, super_type
->name
);
12422 /* Ensure the extended type gets resolved before we do. */
12423 if (super_type
&& !resolve_fl_derived0 (super_type
))
12426 /* An ABSTRACT type must be extensible. */
12427 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12429 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT",
12430 sym
->name
, &sym
->declared_at
);
12434 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12437 bool success
= true;
12439 for ( ; c
!= NULL
; c
= c
->next
)
12441 if (c
->attr
.artificial
)
12445 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12446 && c
->attr
.codimension
12447 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12449 gfc_error ("Coarray component %qs at %L must be allocatable with "
12450 "deferred shape", c
->name
, &c
->loc
);
12456 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12457 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12459 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12460 "shall not be a coarray", c
->name
, &c
->loc
);
12466 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12467 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12468 || c
->attr
.allocatable
))
12470 gfc_error ("Component %qs at %L with coarray component "
12471 "shall be a nonpointer, nonallocatable scalar",
12478 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12480 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12481 "is not an array pointer", c
->name
, &c
->loc
);
12486 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12488 gfc_symbol
*ifc
= c
->ts
.interface
;
12490 if (!sym
->attr
.vtype
&& !check_proc_interface (ifc
, &c
->loc
))
12497 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12499 /* Resolve interface and copy attributes. */
12500 if (ifc
->formal
&& !ifc
->formal_ns
)
12501 resolve_symbol (ifc
);
12502 if (ifc
->attr
.intrinsic
)
12503 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12507 c
->ts
= ifc
->result
->ts
;
12508 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12509 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12510 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12511 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12512 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12517 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12518 c
->attr
.pointer
= ifc
->attr
.pointer
;
12519 c
->attr
.dimension
= ifc
->attr
.dimension
;
12520 c
->as
= gfc_copy_array_spec (ifc
->as
);
12521 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12523 c
->ts
.interface
= ifc
;
12524 c
->attr
.function
= ifc
->attr
.function
;
12525 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12527 c
->attr
.pure
= ifc
->attr
.pure
;
12528 c
->attr
.elemental
= ifc
->attr
.elemental
;
12529 c
->attr
.recursive
= ifc
->attr
.recursive
;
12530 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12531 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12532 /* Copy char length. */
12533 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12535 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12536 if (cl
->length
&& !cl
->resolved
12537 && !gfc_resolve_expr (cl
->length
))
12547 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12549 /* Since PPCs are not implicitly typed, a PPC without an explicit
12550 interface must be a subroutine. */
12551 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12554 /* Procedure pointer components: Check PASS arg. */
12555 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12556 && !sym
->attr
.vtype
)
12558 gfc_symbol
* me_arg
;
12560 if (c
->tb
->pass_arg
)
12562 gfc_formal_arglist
* i
;
12564 /* If an explicit passing argument name is given, walk the arg-list
12565 and look for it. */
12568 c
->tb
->pass_arg_num
= 1;
12569 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12571 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12576 c
->tb
->pass_arg_num
++;
12581 gfc_error ("Procedure pointer component %qs with PASS(%s) "
12582 "at %L has no argument %qs", c
->name
,
12583 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12591 /* Otherwise, take the first one; there should in fact be at least
12593 c
->tb
->pass_arg_num
= 1;
12594 if (!c
->ts
.interface
->formal
)
12596 gfc_error ("Procedure pointer component %qs with PASS at %L "
12597 "must have at least one argument",
12603 me_arg
= c
->ts
.interface
->formal
->sym
;
12606 /* Now check that the argument-type matches. */
12607 gcc_assert (me_arg
);
12608 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12609 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12610 || (me_arg
->ts
.type
== BT_CLASS
12611 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12613 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12614 " the derived type %qs", me_arg
->name
, c
->name
,
12615 me_arg
->name
, &c
->loc
, sym
->name
);
12621 /* Check for C453. */
12622 if (me_arg
->attr
.dimension
)
12624 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12625 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12632 if (me_arg
->attr
.pointer
)
12634 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12635 "may not have the POINTER attribute", me_arg
->name
,
12636 c
->name
, me_arg
->name
, &c
->loc
);
12642 if (me_arg
->attr
.allocatable
)
12644 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12645 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12646 me_arg
->name
, &c
->loc
);
12652 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12654 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12655 " at %L", c
->name
, &c
->loc
);
12662 /* Check type-spec if this is not the parent-type component. */
12663 if (((sym
->attr
.is_class
12664 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12665 || c
!= sym
->components
->ts
.u
.derived
->components
))
12666 || (!sym
->attr
.is_class
12667 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12668 && !sym
->attr
.vtype
12669 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12672 /* If this type is an extension, set the accessibility of the parent
12675 && ((sym
->attr
.is_class
12676 && c
== sym
->components
->ts
.u
.derived
->components
)
12677 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12678 && strcmp (super_type
->name
, c
->name
) == 0)
12679 c
->attr
.access
= super_type
->attr
.access
;
12681 /* If this type is an extension, see if this component has the same name
12682 as an inherited type-bound procedure. */
12683 if (super_type
&& !sym
->attr
.is_class
12684 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12686 gfc_error ("Component %qs of %qs at %L has the same name as an"
12687 " inherited type-bound procedure",
12688 c
->name
, sym
->name
, &c
->loc
);
12692 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12693 && !c
->ts
.deferred
)
12695 if (c
->ts
.u
.cl
->length
== NULL
12696 || (!resolve_charlen(c
->ts
.u
.cl
))
12697 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12699 gfc_error ("Character length of component %qs needs to "
12700 "be a constant specification expression at %L",
12702 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12707 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12708 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12710 gfc_error ("Character component %qs of %qs at %L with deferred "
12711 "length must be a POINTER or ALLOCATABLE",
12712 c
->name
, sym
->name
, &c
->loc
);
12716 /* Add the hidden deferred length field. */
12717 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
12718 && !sym
->attr
.is_class
)
12720 char name
[GFC_MAX_SYMBOL_LEN
+9];
12721 gfc_component
*strlen
;
12722 sprintf (name
, "_%s_length", c
->name
);
12723 strlen
= gfc_find_component (sym
, name
, true, true);
12724 if (strlen
== NULL
)
12726 if (!gfc_add_component (sym
, name
, &strlen
))
12728 strlen
->ts
.type
= BT_INTEGER
;
12729 strlen
->ts
.kind
= gfc_charlen_int_kind
;
12730 strlen
->attr
.access
= ACCESS_PRIVATE
;
12731 strlen
->attr
.artificial
= 1;
12735 if (c
->ts
.type
== BT_DERIVED
12736 && sym
->component_access
!= ACCESS_PRIVATE
12737 && gfc_check_symbol_access (sym
)
12738 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12739 && !c
->ts
.u
.derived
->attr
.use_assoc
12740 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12741 && !gfc_notify_std (GFC_STD_F2003
, "the component %qs is a "
12742 "PRIVATE type and cannot be a component of "
12743 "%qs, which is PUBLIC at %L", c
->name
,
12744 sym
->name
, &sym
->declared_at
))
12747 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12749 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12750 "type %s", c
->name
, &c
->loc
, sym
->name
);
12754 if (sym
->attr
.sequence
)
12756 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12758 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12759 "not have the SEQUENCE attribute",
12760 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12765 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12766 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12767 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12768 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12769 CLASS_DATA (c
)->ts
.u
.derived
12770 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12772 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12773 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12774 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12776 gfc_error ("The pointer component %qs of %qs at %L is a type "
12777 "that has not been declared", c
->name
, sym
->name
,
12782 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12783 && CLASS_DATA (c
)->attr
.class_pointer
12784 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12785 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12786 && !UNLIMITED_POLY (c
))
12788 gfc_error ("The pointer component %qs of %qs at %L is a type "
12789 "that has not been declared", c
->name
, sym
->name
,
12795 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12796 && (!c
->attr
.class_ok
12797 || !(CLASS_DATA (c
)->attr
.class_pointer
12798 || CLASS_DATA (c
)->attr
.allocatable
)))
12800 gfc_error ("Component %qs with CLASS at %L must be allocatable "
12801 "or pointer", c
->name
, &c
->loc
);
12802 /* Prevent a recurrence of the error. */
12803 c
->ts
.type
= BT_UNKNOWN
;
12807 /* Ensure that all the derived type components are put on the
12808 derived type list; even in formal namespaces, where derived type
12809 pointer components might not have been declared. */
12810 if (c
->ts
.type
== BT_DERIVED
12812 && c
->ts
.u
.derived
->components
12814 && sym
!= c
->ts
.u
.derived
)
12815 add_dt_to_dt_list (c
->ts
.u
.derived
);
12817 if (!gfc_resolve_array_spec (c
->as
,
12818 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12819 || c
->attr
.allocatable
)))
12822 if (c
->initializer
&& !sym
->attr
.vtype
12823 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12830 check_defined_assignments (sym
);
12832 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12833 sym
->attr
.defined_assign_comp
12834 = super_type
->attr
.defined_assign_comp
;
12836 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12837 all DEFERRED bindings are overridden. */
12838 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12839 && !sym
->attr
.is_class
12840 && !ensure_not_abstract (sym
, super_type
))
12843 /* Add derived type to the derived type list. */
12844 add_dt_to_dt_list (sym
);
12850 /* The following procedure does the full resolution of a derived type,
12851 including resolution of all type-bound procedures (if present). In contrast
12852 to 'resolve_fl_derived0' this can only be done after the module has been
12853 parsed completely. */
12856 resolve_fl_derived (gfc_symbol
*sym
)
12858 gfc_symbol
*gen_dt
= NULL
;
12860 if (sym
->attr
.unlimited_polymorphic
)
12863 if (!sym
->attr
.is_class
)
12864 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12865 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12866 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12867 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12868 && !gfc_notify_std_1 (GFC_STD_F2003
, "Generic name '%s' of function "
12869 "'%s' at %L being the same name as derived "
12870 "type at %L", sym
->name
,
12871 gen_dt
->generic
->sym
== sym
12872 ? gen_dt
->generic
->next
->sym
->name
12873 : gen_dt
->generic
->sym
->name
,
12874 gen_dt
->generic
->sym
== sym
12875 ? &gen_dt
->generic
->next
->sym
->declared_at
12876 : &gen_dt
->generic
->sym
->declared_at
,
12877 &sym
->declared_at
))
12880 /* Resolve the finalizer procedures. */
12881 if (!gfc_resolve_finalizers (sym
, NULL
))
12884 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12886 /* Fix up incomplete CLASS symbols. */
12887 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12888 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12890 /* Nothing more to do for unlimited polymorphic entities. */
12891 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12893 else if (vptr
->ts
.u
.derived
== NULL
)
12895 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12897 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12901 if (!resolve_fl_derived0 (sym
))
12904 /* Resolve the type-bound procedures. */
12905 if (!resolve_typebound_procedures (sym
))
12913 resolve_fl_namelist (gfc_symbol
*sym
)
12918 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12920 /* Check again, the check in match only works if NAMELIST comes
12922 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12924 gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
12925 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12929 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12930 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12931 "with assumed shape in namelist %qs at %L",
12932 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12935 if (is_non_constant_shape_array (nl
->sym
)
12936 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object %qs "
12937 "with nonconstant shape in namelist %qs at %L",
12938 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12941 if (nl
->sym
->ts
.type
== BT_CHARACTER
12942 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12943 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12944 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs with "
12945 "nonconstant character length in "
12946 "namelist %qs at %L", nl
->sym
->name
,
12947 sym
->name
, &sym
->declared_at
))
12950 /* FIXME: Once UDDTIO is implemented, the following can be
12952 if (nl
->sym
->ts
.type
== BT_CLASS
)
12954 gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
12955 "polymorphic and requires a defined input/output "
12956 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12960 if (nl
->sym
->ts
.type
== BT_DERIVED
12961 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12962 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12964 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object %qs in "
12965 "namelist %qs at %L with ALLOCATABLE "
12966 "or POINTER components", nl
->sym
->name
,
12967 sym
->name
, &sym
->declared_at
))
12970 /* FIXME: Once UDDTIO is implemented, the following can be
12972 gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
12973 "ALLOCATABLE or POINTER components and thus requires "
12974 "a defined input/output procedure", nl
->sym
->name
,
12975 sym
->name
, &sym
->declared_at
);
12980 /* Reject PRIVATE objects in a PUBLIC namelist. */
12981 if (gfc_check_symbol_access (sym
))
12983 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12985 if (!nl
->sym
->attr
.use_assoc
12986 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12987 && !gfc_check_symbol_access (nl
->sym
))
12989 gfc_error ("NAMELIST object %qs was declared PRIVATE and "
12990 "cannot be member of PUBLIC namelist %qs at %L",
12991 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12995 /* Types with private components that came here by USE-association. */
12996 if (nl
->sym
->ts
.type
== BT_DERIVED
12997 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12999 gfc_error ("NAMELIST object %qs has use-associated PRIVATE "
13000 "components and cannot be member of namelist %qs at %L",
13001 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13005 /* Types with private components that are defined in the same module. */
13006 if (nl
->sym
->ts
.type
== BT_DERIVED
13007 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13008 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13010 gfc_error ("NAMELIST object %qs has PRIVATE components and "
13011 "cannot be a member of PUBLIC namelist %qs at %L",
13012 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13019 /* 14.1.2 A module or internal procedure represent local entities
13020 of the same type as a namelist member and so are not allowed. */
13021 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13023 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13026 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13027 if ((nl
->sym
== sym
->ns
->proc_name
)
13029 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13034 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13035 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13037 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13038 "attribute in %qs at %L", nlsym
->name
,
13039 &sym
->declared_at
);
13049 resolve_fl_parameter (gfc_symbol
*sym
)
13051 /* A parameter array's shape needs to be constant. */
13052 if (sym
->as
!= NULL
13053 && (sym
->as
->type
== AS_DEFERRED
13054 || is_non_constant_shape_array (sym
)))
13056 gfc_error ("Parameter array %qs at %L cannot be automatic "
13057 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13061 /* Make sure a parameter that has been implicitly typed still
13062 matches the implicit type, since PARAMETER statements can precede
13063 IMPLICIT statements. */
13064 if (sym
->attr
.implicit_type
13065 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13068 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a "
13069 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13073 /* Make sure the types of derived parameters are consistent. This
13074 type checking is deferred until resolution because the type may
13075 refer to a derived type from the host. */
13076 if (sym
->ts
.type
== BT_DERIVED
13077 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13079 gfc_error ("Incompatible derived type in PARAMETER at %L",
13080 &sym
->value
->where
);
13087 /* Do anything necessary to resolve a symbol. Right now, we just
13088 assume that an otherwise unknown symbol is a variable. This sort
13089 of thing commonly happens for symbols in module. */
13092 resolve_symbol (gfc_symbol
*sym
)
13094 int check_constant
, mp_flag
;
13095 gfc_symtree
*symtree
;
13096 gfc_symtree
*this_symtree
;
13099 symbol_attribute class_attr
;
13100 gfc_array_spec
*as
;
13101 bool saved_specification_expr
;
13107 if (sym
->attr
.artificial
)
13110 if (sym
->attr
.unlimited_polymorphic
)
13113 if (sym
->attr
.flavor
== FL_UNKNOWN
13114 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13115 && !sym
->attr
.generic
&& !sym
->attr
.external
13116 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13117 && sym
->ts
.type
== BT_UNKNOWN
))
13120 /* If we find that a flavorless symbol is an interface in one of the
13121 parent namespaces, find its symtree in this namespace, free the
13122 symbol and set the symtree to point to the interface symbol. */
13123 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13125 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13126 if (symtree
&& (symtree
->n
.sym
->generic
||
13127 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13128 && sym
->ns
->construct_entities
)))
13130 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13132 if (this_symtree
->n
.sym
== sym
)
13134 symtree
->n
.sym
->refs
++;
13135 gfc_release_symbol (sym
);
13136 this_symtree
->n
.sym
= symtree
->n
.sym
;
13142 /* Otherwise give it a flavor according to such attributes as
13144 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13145 && sym
->attr
.intrinsic
== 0)
13146 sym
->attr
.flavor
= FL_VARIABLE
;
13147 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13149 sym
->attr
.flavor
= FL_PROCEDURE
;
13150 if (sym
->attr
.dimension
)
13151 sym
->attr
.function
= 1;
13155 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13156 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13158 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13159 && !resolve_procedure_interface (sym
))
13162 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13163 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13165 if (sym
->attr
.external
)
13166 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13167 "at %L", &sym
->declared_at
);
13169 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13170 "at %L", &sym
->declared_at
);
13175 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13178 /* Symbols that are module procedures with results (functions) have
13179 the types and array specification copied for type checking in
13180 procedures that call them, as well as for saving to a module
13181 file. These symbols can't stand the scrutiny that their results
13183 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13185 /* Make sure that the intrinsic is consistent with its internal
13186 representation. This needs to be done before assigning a default
13187 type to avoid spurious warnings. */
13188 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13189 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13192 /* Resolve associate names. */
13194 resolve_assoc_var (sym
, true);
13196 /* Assign default type to symbols that need one and don't have one. */
13197 if (sym
->ts
.type
== BT_UNKNOWN
)
13199 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13201 gfc_set_default_type (sym
, 1, NULL
);
13204 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13205 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13206 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13207 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13209 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13211 /* The specific case of an external procedure should emit an error
13212 in the case that there is no implicit type. */
13214 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13217 /* Result may be in another namespace. */
13218 resolve_symbol (sym
->result
);
13220 if (!sym
->result
->attr
.proc_pointer
)
13222 sym
->ts
= sym
->result
->ts
;
13223 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13224 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13225 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13226 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13227 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13232 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13234 bool saved_specification_expr
= specification_expr
;
13235 specification_expr
= true;
13236 gfc_resolve_array_spec (sym
->result
->as
, false);
13237 specification_expr
= saved_specification_expr
;
13240 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13242 as
= CLASS_DATA (sym
)->as
;
13243 class_attr
= CLASS_DATA (sym
)->attr
;
13244 class_attr
.pointer
= class_attr
.class_pointer
;
13248 class_attr
= sym
->attr
;
13253 if (sym
->attr
.contiguous
13254 && (!class_attr
.dimension
13255 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13256 && !class_attr
.pointer
)))
13258 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an "
13259 "array pointer or an assumed-shape or assumed-rank array",
13260 sym
->name
, &sym
->declared_at
);
13264 /* Assumed size arrays and assumed shape arrays must be dummy
13265 arguments. Array-spec's of implied-shape should have been resolved to
13266 AS_EXPLICIT already. */
13270 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13271 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13272 || as
->type
== AS_ASSUMED_SHAPE
)
13273 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13275 if (as
->type
== AS_ASSUMED_SIZE
)
13276 gfc_error ("Assumed size array at %L must be a dummy argument",
13277 &sym
->declared_at
);
13279 gfc_error ("Assumed shape array at %L must be a dummy argument",
13280 &sym
->declared_at
);
13283 /* TS 29113, C535a. */
13284 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13285 && !sym
->attr
.select_type_temporary
)
13287 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13288 &sym
->declared_at
);
13291 if (as
->type
== AS_ASSUMED_RANK
13292 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13294 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13295 "CODIMENSION attribute", &sym
->declared_at
);
13300 /* Make sure symbols with known intent or optional are really dummy
13301 variable. Because of ENTRY statement, this has to be deferred
13302 until resolution time. */
13304 if (!sym
->attr
.dummy
13305 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13307 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13311 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13313 gfc_error ("%qs at %L cannot have the VALUE attribute because "
13314 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13318 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13320 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13321 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13323 gfc_error ("Character dummy variable %qs at %L with VALUE "
13324 "attribute must have constant length",
13325 sym
->name
, &sym
->declared_at
);
13329 if (sym
->ts
.is_c_interop
13330 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13332 gfc_error ("C interoperable character dummy variable %qs at %L "
13333 "with VALUE attribute must have length one",
13334 sym
->name
, &sym
->declared_at
);
13339 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13340 && sym
->ts
.u
.derived
->attr
.generic
)
13342 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13343 if (!sym
->ts
.u
.derived
)
13345 gfc_error ("The derived type %qs at %L is of type %qs, "
13346 "which has not been defined", sym
->name
,
13347 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13348 sym
->ts
.type
= BT_UNKNOWN
;
13353 /* Use the same constraints as TYPE(*), except for the type check
13354 and that only scalars and assumed-size arrays are permitted. */
13355 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13357 if (!sym
->attr
.dummy
)
13359 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13360 "a dummy argument", sym
->name
, &sym
->declared_at
);
13364 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13365 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13366 && sym
->ts
.type
!= BT_COMPLEX
)
13368 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13369 "of type TYPE(*) or of an numeric intrinsic type",
13370 sym
->name
, &sym
->declared_at
);
13374 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13375 || sym
->attr
.pointer
|| sym
->attr
.value
)
13377 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13378 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13379 "attribute", sym
->name
, &sym
->declared_at
);
13383 if (sym
->attr
.intent
== INTENT_OUT
)
13385 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13386 "have the INTENT(OUT) attribute",
13387 sym
->name
, &sym
->declared_at
);
13390 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13392 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13393 "either be a scalar or an assumed-size array",
13394 sym
->name
, &sym
->declared_at
);
13398 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13399 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13401 sym
->ts
.type
= BT_ASSUMED
;
13402 sym
->as
= gfc_get_array_spec ();
13403 sym
->as
->type
= AS_ASSUMED_SIZE
;
13405 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13407 else if (sym
->ts
.type
== BT_ASSUMED
)
13409 /* TS 29113, C407a. */
13410 if (!sym
->attr
.dummy
)
13412 gfc_error ("Assumed type of variable %s at %L is only permitted "
13413 "for dummy variables", sym
->name
, &sym
->declared_at
);
13416 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13417 || sym
->attr
.pointer
|| sym
->attr
.value
)
13419 gfc_error ("Assumed-type variable %s at %L may not have the "
13420 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13421 sym
->name
, &sym
->declared_at
);
13424 if (sym
->attr
.intent
== INTENT_OUT
)
13426 gfc_error ("Assumed-type variable %s at %L may not have the "
13427 "INTENT(OUT) attribute",
13428 sym
->name
, &sym
->declared_at
);
13431 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13433 gfc_error ("Assumed-type variable %s at %L shall not be an "
13434 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13439 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13440 do this for something that was implicitly typed because that is handled
13441 in gfc_set_default_type. Handle dummy arguments and procedure
13442 definitions separately. Also, anything that is use associated is not
13443 handled here but instead is handled in the module it is declared in.
13444 Finally, derived type definitions are allowed to be BIND(C) since that
13445 only implies that they're interoperable, and they are checked fully for
13446 interoperability when a variable is declared of that type. */
13447 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13448 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13449 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13453 /* First, make sure the variable is declared at the
13454 module-level scope (J3/04-007, Section 15.3). */
13455 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13456 sym
->attr
.in_common
== 0)
13458 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13459 "is neither a COMMON block nor declared at the "
13460 "module level scope", sym
->name
, &(sym
->declared_at
));
13463 else if (sym
->common_head
!= NULL
)
13465 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13469 /* If type() declaration, we need to verify that the components
13470 of the given type are all C interoperable, etc. */
13471 if (sym
->ts
.type
== BT_DERIVED
&&
13472 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13474 /* Make sure the user marked the derived type as BIND(C). If
13475 not, call the verify routine. This could print an error
13476 for the derived type more than once if multiple variables
13477 of that type are declared. */
13478 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13479 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13483 /* Verify the variable itself as C interoperable if it
13484 is BIND(C). It is not possible for this to succeed if
13485 the verify_bind_c_derived_type failed, so don't have to handle
13486 any error returned by verify_bind_c_derived_type. */
13487 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13488 sym
->common_block
);
13493 /* clear the is_bind_c flag to prevent reporting errors more than
13494 once if something failed. */
13495 sym
->attr
.is_bind_c
= 0;
13500 /* If a derived type symbol has reached this point, without its
13501 type being declared, we have an error. Notice that most
13502 conditions that produce undefined derived types have already
13503 been dealt with. However, the likes of:
13504 implicit type(t) (t) ..... call foo (t) will get us here if
13505 the type is not declared in the scope of the implicit
13506 statement. Change the type to BT_UNKNOWN, both because it is so
13507 and to prevent an ICE. */
13508 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13509 && sym
->ts
.u
.derived
->components
== NULL
13510 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13512 gfc_error ("The derived type %qs at %L is of type %qs, "
13513 "which has not been defined", sym
->name
,
13514 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13515 sym
->ts
.type
= BT_UNKNOWN
;
13519 /* Make sure that the derived type has been resolved and that the
13520 derived type is visible in the symbol's namespace, if it is a
13521 module function and is not PRIVATE. */
13522 if (sym
->ts
.type
== BT_DERIVED
13523 && sym
->ts
.u
.derived
->attr
.use_assoc
13524 && sym
->ns
->proc_name
13525 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13526 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13529 /* Unless the derived-type declaration is use associated, Fortran 95
13530 does not allow public entries of private derived types.
13531 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13532 161 in 95-006r3. */
13533 if (sym
->ts
.type
== BT_DERIVED
13534 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13535 && !sym
->ts
.u
.derived
->attr
.use_assoc
13536 && gfc_check_symbol_access (sym
)
13537 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13538 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s %qs at %L of PRIVATE "
13539 "derived type %qs",
13540 (sym
->attr
.flavor
== FL_PARAMETER
)
13541 ? "parameter" : "variable",
13542 sym
->name
, &sym
->declared_at
,
13543 sym
->ts
.u
.derived
->name
))
13546 /* F2008, C1302. */
13547 if (sym
->ts
.type
== BT_DERIVED
13548 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13549 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13550 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13551 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13553 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13554 "type LOCK_TYPE must be a coarray", sym
->name
,
13555 &sym
->declared_at
);
13559 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13560 default initialization is defined (5.1.2.4.4). */
13561 if (sym
->ts
.type
== BT_DERIVED
13563 && sym
->attr
.intent
== INTENT_OUT
13565 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13567 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13569 if (c
->initializer
)
13571 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is "
13572 "ASSUMED SIZE and so cannot have a default initializer",
13573 sym
->name
, &sym
->declared_at
);
13580 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13581 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13583 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be "
13584 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13589 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13590 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13591 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13592 || class_attr
.codimension
)
13593 && (sym
->attr
.result
|| sym
->result
== sym
))
13595 gfc_error ("Function result %qs at %L shall not be a coarray or have "
13596 "a coarray component", sym
->name
, &sym
->declared_at
);
13601 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13602 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13604 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13605 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13610 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13611 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13612 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13613 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13614 || class_attr
.allocatable
))
13616 gfc_error ("Variable %qs at %L with coarray component shall be a "
13617 "nonpointer, nonallocatable scalar, which is not a coarray",
13618 sym
->name
, &sym
->declared_at
);
13622 /* F2008, C526. The function-result case was handled above. */
13623 if (class_attr
.codimension
13624 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13625 || sym
->attr
.select_type_temporary
13626 || sym
->ns
->save_all
13627 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13628 || sym
->ns
->proc_name
->attr
.is_main_program
13629 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13631 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE "
13632 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13636 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13637 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13639 gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
13640 "deferred shape", sym
->name
, &sym
->declared_at
);
13643 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13644 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13646 gfc_error ("Allocatable coarray variable %qs at %L must have "
13647 "deferred shape", sym
->name
, &sym
->declared_at
);
13652 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13653 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13654 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13655 || (class_attr
.codimension
&& class_attr
.allocatable
))
13656 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13658 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an "
13659 "allocatable coarray or have coarray components",
13660 sym
->name
, &sym
->declared_at
);
13664 if (class_attr
.codimension
&& sym
->attr
.dummy
13665 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13667 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) "
13668 "procedure %qs", sym
->name
, &sym
->declared_at
,
13669 sym
->ns
->proc_name
->name
);
13673 if (sym
->ts
.type
== BT_LOGICAL
13674 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13675 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13676 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13679 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13680 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13682 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13683 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument %qs at "
13684 "%L with non-C_Bool kind in BIND(C) procedure "
13685 "%qs", sym
->name
, &sym
->declared_at
,
13686 sym
->ns
->proc_name
->name
))
13688 else if (!gfc_logical_kinds
[i
].c_bool
13689 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13690 "%qs at %L with non-C_Bool kind in "
13691 "BIND(C) procedure %qs", sym
->name
,
13693 sym
->attr
.function
? sym
->name
13694 : sym
->ns
->proc_name
->name
))
13698 switch (sym
->attr
.flavor
)
13701 if (!resolve_fl_variable (sym
, mp_flag
))
13706 if (!resolve_fl_procedure (sym
, mp_flag
))
13711 if (!resolve_fl_namelist (sym
))
13716 if (!resolve_fl_parameter (sym
))
13724 /* Resolve array specifier. Check as well some constraints
13725 on COMMON blocks. */
13727 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13729 /* Set the formal_arg_flag so that check_conflict will not throw
13730 an error for host associated variables in the specification
13731 expression for an array_valued function. */
13732 if (sym
->attr
.function
&& sym
->as
)
13733 formal_arg_flag
= 1;
13735 saved_specification_expr
= specification_expr
;
13736 specification_expr
= true;
13737 gfc_resolve_array_spec (sym
->as
, check_constant
);
13738 specification_expr
= saved_specification_expr
;
13740 formal_arg_flag
= 0;
13742 /* Resolve formal namespaces. */
13743 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13744 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13745 gfc_resolve (sym
->formal_ns
);
13747 /* Make sure the formal namespace is present. */
13748 if (sym
->formal
&& !sym
->formal_ns
)
13750 gfc_formal_arglist
*formal
= sym
->formal
;
13751 while (formal
&& !formal
->sym
)
13752 formal
= formal
->next
;
13756 sym
->formal_ns
= formal
->sym
->ns
;
13757 if (sym
->ns
!= formal
->sym
->ns
)
13758 sym
->formal_ns
->refs
++;
13762 /* Check threadprivate restrictions. */
13763 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13764 && (!sym
->attr
.in_common
13765 && sym
->module
== NULL
13766 && (sym
->ns
->proc_name
== NULL
13767 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13768 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13770 /* Check omp declare target restrictions. */
13771 if (sym
->attr
.omp_declare_target
13772 && sym
->attr
.flavor
== FL_VARIABLE
13774 && !sym
->ns
->save_all
13775 && (!sym
->attr
.in_common
13776 && sym
->module
== NULL
13777 && (sym
->ns
->proc_name
== NULL
13778 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13779 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd",
13780 sym
->name
, &sym
->declared_at
);
13782 /* If we have come this far we can apply default-initializers, as
13783 described in 14.7.5, to those variables that have not already
13784 been assigned one. */
13785 if (sym
->ts
.type
== BT_DERIVED
13787 && !sym
->attr
.allocatable
13788 && !sym
->attr
.alloc_comp
)
13790 symbol_attribute
*a
= &sym
->attr
;
13792 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13793 && !a
->in_common
&& !a
->use_assoc
13794 && (a
->referenced
|| a
->result
)
13795 && !(a
->function
&& sym
!= sym
->result
))
13796 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13797 apply_default_init (sym
);
13800 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13801 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13802 && !CLASS_DATA (sym
)->attr
.class_pointer
13803 && !CLASS_DATA (sym
)->attr
.allocatable
)
13804 apply_default_init (sym
);
13806 /* If this symbol has a type-spec, check it. */
13807 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13808 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13809 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13814 /************* Resolve DATA statements *************/
13818 gfc_data_value
*vnode
;
13824 /* Advance the values structure to point to the next value in the data list. */
13827 next_data_value (void)
13829 while (mpz_cmp_ui (values
.left
, 0) == 0)
13832 if (values
.vnode
->next
== NULL
)
13835 values
.vnode
= values
.vnode
->next
;
13836 mpz_set (values
.left
, values
.vnode
->repeat
);
13844 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13850 ar_type mark
= AR_UNKNOWN
;
13852 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13858 if (!gfc_resolve_expr (var
->expr
))
13862 mpz_init_set_si (offset
, 0);
13865 if (e
->expr_type
!= EXPR_VARIABLE
)
13866 gfc_internal_error ("check_data_variable(): Bad expression");
13868 sym
= e
->symtree
->n
.sym
;
13870 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13872 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON",
13873 sym
->name
, &sym
->declared_at
);
13876 if (e
->ref
== NULL
&& sym
->as
)
13878 gfc_error ("DATA array %qs at %L must be specified in a previous"
13879 " declaration", sym
->name
, where
);
13883 has_pointer
= sym
->attr
.pointer
;
13885 if (gfc_is_coindexed (e
))
13887 gfc_error ("DATA element %qs at %L cannot have a coindex", sym
->name
,
13892 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13894 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13898 && ref
->type
== REF_ARRAY
13899 && ref
->u
.ar
.type
!= AR_FULL
)
13901 gfc_error ("DATA element %qs at %L is a pointer and so must "
13902 "be a full array", sym
->name
, where
);
13907 if (e
->rank
== 0 || has_pointer
)
13909 mpz_init_set_ui (size
, 1);
13916 /* Find the array section reference. */
13917 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13919 if (ref
->type
!= REF_ARRAY
)
13921 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13927 /* Set marks according to the reference pattern. */
13928 switch (ref
->u
.ar
.type
)
13936 /* Get the start position of array section. */
13937 gfc_get_section_index (ar
, section_index
, &offset
);
13942 gcc_unreachable ();
13945 if (!gfc_array_size (e
, &size
))
13947 gfc_error ("Nonconstant array section at %L in DATA statement",
13949 mpz_clear (offset
);
13956 while (mpz_cmp_ui (size
, 0) > 0)
13958 if (!next_data_value ())
13960 gfc_error ("DATA statement at %L has more variables than values",
13966 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13970 /* If we have more than one element left in the repeat count,
13971 and we have more than one element left in the target variable,
13972 then create a range assignment. */
13973 /* FIXME: Only done for full arrays for now, since array sections
13975 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13976 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13980 if (mpz_cmp (size
, values
.left
) >= 0)
13982 mpz_init_set (range
, values
.left
);
13983 mpz_sub (size
, size
, values
.left
);
13984 mpz_set_ui (values
.left
, 0);
13988 mpz_init_set (range
, size
);
13989 mpz_sub (values
.left
, values
.left
, size
);
13990 mpz_set_ui (size
, 0);
13993 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13996 mpz_add (offset
, offset
, range
);
14003 /* Assign initial value to symbol. */
14006 mpz_sub_ui (values
.left
, values
.left
, 1);
14007 mpz_sub_ui (size
, size
, 1);
14009 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14014 if (mark
== AR_FULL
)
14015 mpz_add_ui (offset
, offset
, 1);
14017 /* Modify the array section indexes and recalculate the offset
14018 for next element. */
14019 else if (mark
== AR_SECTION
)
14020 gfc_advance_section (section_index
, ar
, &offset
);
14024 if (mark
== AR_SECTION
)
14026 for (i
= 0; i
< ar
->dimen
; i
++)
14027 mpz_clear (section_index
[i
]);
14031 mpz_clear (offset
);
14037 static bool traverse_data_var (gfc_data_variable
*, locus
*);
14039 /* Iterate over a list of elements in a DATA statement. */
14042 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14045 iterator_stack frame
;
14046 gfc_expr
*e
, *start
, *end
, *step
;
14047 bool retval
= true;
14049 mpz_init (frame
.value
);
14052 start
= gfc_copy_expr (var
->iter
.start
);
14053 end
= gfc_copy_expr (var
->iter
.end
);
14054 step
= gfc_copy_expr (var
->iter
.step
);
14056 if (!gfc_simplify_expr (start
, 1)
14057 || start
->expr_type
!= EXPR_CONSTANT
)
14059 gfc_error ("start of implied-do loop at %L could not be "
14060 "simplified to a constant value", &start
->where
);
14064 if (!gfc_simplify_expr (end
, 1)
14065 || end
->expr_type
!= EXPR_CONSTANT
)
14067 gfc_error ("end of implied-do loop at %L could not be "
14068 "simplified to a constant value", &start
->where
);
14072 if (!gfc_simplify_expr (step
, 1)
14073 || step
->expr_type
!= EXPR_CONSTANT
)
14075 gfc_error ("step of implied-do loop at %L could not be "
14076 "simplified to a constant value", &start
->where
);
14081 mpz_set (trip
, end
->value
.integer
);
14082 mpz_sub (trip
, trip
, start
->value
.integer
);
14083 mpz_add (trip
, trip
, step
->value
.integer
);
14085 mpz_div (trip
, trip
, step
->value
.integer
);
14087 mpz_set (frame
.value
, start
->value
.integer
);
14089 frame
.prev
= iter_stack
;
14090 frame
.variable
= var
->iter
.var
->symtree
;
14091 iter_stack
= &frame
;
14093 while (mpz_cmp_ui (trip
, 0) > 0)
14095 if (!traverse_data_var (var
->list
, where
))
14101 e
= gfc_copy_expr (var
->expr
);
14102 if (!gfc_simplify_expr (e
, 1))
14109 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14111 mpz_sub_ui (trip
, trip
, 1);
14115 mpz_clear (frame
.value
);
14118 gfc_free_expr (start
);
14119 gfc_free_expr (end
);
14120 gfc_free_expr (step
);
14122 iter_stack
= frame
.prev
;
14127 /* Type resolve variables in the variable list of a DATA statement. */
14130 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14134 for (; var
; var
= var
->next
)
14136 if (var
->expr
== NULL
)
14137 t
= traverse_data_list (var
, where
);
14139 t
= check_data_variable (var
, where
);
14149 /* Resolve the expressions and iterators associated with a data statement.
14150 This is separate from the assignment checking because data lists should
14151 only be resolved once. */
14154 resolve_data_variables (gfc_data_variable
*d
)
14156 for (; d
; d
= d
->next
)
14158 if (d
->list
== NULL
)
14160 if (!gfc_resolve_expr (d
->expr
))
14165 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14168 if (!resolve_data_variables (d
->list
))
14177 /* Resolve a single DATA statement. We implement this by storing a pointer to
14178 the value list into static variables, and then recursively traversing the
14179 variables list, expanding iterators and such. */
14182 resolve_data (gfc_data
*d
)
14185 if (!resolve_data_variables (d
->var
))
14188 values
.vnode
= d
->value
;
14189 if (d
->value
== NULL
)
14190 mpz_set_ui (values
.left
, 0);
14192 mpz_set (values
.left
, d
->value
->repeat
);
14194 if (!traverse_data_var (d
->var
, &d
->where
))
14197 /* At this point, we better not have any values left. */
14199 if (next_data_value ())
14200 gfc_error ("DATA statement at %L has more values than variables",
14205 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14206 accessed by host or use association, is a dummy argument to a pure function,
14207 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14208 is storage associated with any such variable, shall not be used in the
14209 following contexts: (clients of this function). */
14211 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14212 procedure. Returns zero if assignment is OK, nonzero if there is a
14215 gfc_impure_variable (gfc_symbol
*sym
)
14220 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14223 /* Check if the symbol's ns is inside the pure procedure. */
14224 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14228 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14232 proc
= sym
->ns
->proc_name
;
14233 if (sym
->attr
.dummy
14234 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14235 || proc
->attr
.function
))
14238 /* TODO: Sort out what can be storage associated, if anything, and include
14239 it here. In principle equivalences should be scanned but it does not
14240 seem to be possible to storage associate an impure variable this way. */
14245 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14246 current namespace is inside a pure procedure. */
14249 gfc_pure (gfc_symbol
*sym
)
14251 symbol_attribute attr
;
14256 /* Check if the current namespace or one of its parents
14257 belongs to a pure procedure. */
14258 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14260 sym
= ns
->proc_name
;
14264 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14272 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14276 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14277 checks if the current namespace is implicitly pure. Note that this
14278 function returns false for a PURE procedure. */
14281 gfc_implicit_pure (gfc_symbol
*sym
)
14287 /* Check if the current procedure is implicit_pure. Walk up
14288 the procedure list until we find a procedure. */
14289 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14291 sym
= ns
->proc_name
;
14295 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14300 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14301 && !sym
->attr
.pure
;
14306 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14312 /* Check if the current procedure is implicit_pure. Walk up
14313 the procedure list until we find a procedure. */
14314 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14316 sym
= ns
->proc_name
;
14320 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14325 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14326 sym
->attr
.implicit_pure
= 0;
14328 sym
->attr
.pure
= 0;
14332 /* Test whether the current procedure is elemental or not. */
14335 gfc_elemental (gfc_symbol
*sym
)
14337 symbol_attribute attr
;
14340 sym
= gfc_current_ns
->proc_name
;
14345 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14349 /* Warn about unused labels. */
14352 warn_unused_fortran_label (gfc_st_label
*label
)
14357 warn_unused_fortran_label (label
->left
);
14359 if (label
->defined
== ST_LABEL_UNKNOWN
)
14362 switch (label
->referenced
)
14364 case ST_LABEL_UNKNOWN
:
14365 gfc_warning (0, "Label %d at %L defined but not used", label
->value
,
14369 case ST_LABEL_BAD_TARGET
:
14370 gfc_warning (0, "Label %d at %L defined but cannot be used",
14371 label
->value
, &label
->where
);
14378 warn_unused_fortran_label (label
->right
);
14382 /* Returns the sequence type of a symbol or sequence. */
14385 sequence_type (gfc_typespec ts
)
14394 if (ts
.u
.derived
->components
== NULL
)
14395 return SEQ_NONDEFAULT
;
14397 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14398 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14399 if (sequence_type (c
->ts
) != result
)
14405 if (ts
.kind
!= gfc_default_character_kind
)
14406 return SEQ_NONDEFAULT
;
14408 return SEQ_CHARACTER
;
14411 if (ts
.kind
!= gfc_default_integer_kind
)
14412 return SEQ_NONDEFAULT
;
14414 return SEQ_NUMERIC
;
14417 if (!(ts
.kind
== gfc_default_real_kind
14418 || ts
.kind
== gfc_default_double_kind
))
14419 return SEQ_NONDEFAULT
;
14421 return SEQ_NUMERIC
;
14424 if (ts
.kind
!= gfc_default_complex_kind
)
14425 return SEQ_NONDEFAULT
;
14427 return SEQ_NUMERIC
;
14430 if (ts
.kind
!= gfc_default_logical_kind
)
14431 return SEQ_NONDEFAULT
;
14433 return SEQ_NUMERIC
;
14436 return SEQ_NONDEFAULT
;
14441 /* Resolve derived type EQUIVALENCE object. */
14444 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14446 gfc_component
*c
= derived
->components
;
14451 /* Shall not be an object of nonsequence derived type. */
14452 if (!derived
->attr
.sequence
)
14454 gfc_error ("Derived type variable %qs at %L must have SEQUENCE "
14455 "attribute to be an EQUIVALENCE object", sym
->name
,
14460 /* Shall not have allocatable components. */
14461 if (derived
->attr
.alloc_comp
)
14463 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE "
14464 "components to be an EQUIVALENCE object",sym
->name
,
14469 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14471 gfc_error ("Derived type variable %qs at %L with default "
14472 "initialization cannot be in EQUIVALENCE with a variable "
14473 "in COMMON", sym
->name
, &e
->where
);
14477 for (; c
; c
= c
->next
)
14479 if (c
->ts
.type
== BT_DERIVED
14480 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14483 /* Shall not be an object of sequence derived type containing a pointer
14484 in the structure. */
14485 if (c
->attr
.pointer
)
14487 gfc_error ("Derived type variable %qs at %L with pointer "
14488 "component(s) cannot be an EQUIVALENCE object",
14489 sym
->name
, &e
->where
);
14497 /* Resolve equivalence object.
14498 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14499 an allocatable array, an object of nonsequence derived type, an object of
14500 sequence derived type containing a pointer at any level of component
14501 selection, an automatic object, a function name, an entry name, a result
14502 name, a named constant, a structure component, or a subobject of any of
14503 the preceding objects. A substring shall not have length zero. A
14504 derived type shall not have components with default initialization nor
14505 shall two objects of an equivalence group be initialized.
14506 Either all or none of the objects shall have an protected attribute.
14507 The simple constraints are done in symbol.c(check_conflict) and the rest
14508 are implemented here. */
14511 resolve_equivalence (gfc_equiv
*eq
)
14514 gfc_symbol
*first_sym
;
14517 locus
*last_where
= NULL
;
14518 seq_type eq_type
, last_eq_type
;
14519 gfc_typespec
*last_ts
;
14520 int object
, cnt_protected
;
14523 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14525 first_sym
= eq
->expr
->symtree
->n
.sym
;
14529 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14533 e
->ts
= e
->symtree
->n
.sym
->ts
;
14534 /* match_varspec might not know yet if it is seeing
14535 array reference or substring reference, as it doesn't
14537 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14539 gfc_ref
*ref
= e
->ref
;
14540 sym
= e
->symtree
->n
.sym
;
14542 if (sym
->attr
.dimension
)
14544 ref
->u
.ar
.as
= sym
->as
;
14548 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14549 if (e
->ts
.type
== BT_CHARACTER
14551 && ref
->type
== REF_ARRAY
14552 && ref
->u
.ar
.dimen
== 1
14553 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14554 && ref
->u
.ar
.stride
[0] == NULL
)
14556 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14557 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14560 /* Optimize away the (:) reference. */
14561 if (start
== NULL
&& end
== NULL
)
14564 e
->ref
= ref
->next
;
14566 e
->ref
->next
= ref
->next
;
14571 ref
->type
= REF_SUBSTRING
;
14573 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14575 ref
->u
.ss
.start
= start
;
14576 if (end
== NULL
&& e
->ts
.u
.cl
)
14577 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14578 ref
->u
.ss
.end
= end
;
14579 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14586 /* Any further ref is an error. */
14589 gcc_assert (ref
->type
== REF_ARRAY
);
14590 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14596 if (!gfc_resolve_expr (e
))
14599 sym
= e
->symtree
->n
.sym
;
14601 if (sym
->attr
.is_protected
)
14603 if (cnt_protected
> 0 && cnt_protected
!= object
)
14605 gfc_error ("Either all or none of the objects in the "
14606 "EQUIVALENCE set at %L shall have the "
14607 "PROTECTED attribute",
14612 /* Shall not equivalence common block variables in a PURE procedure. */
14613 if (sym
->ns
->proc_name
14614 && sym
->ns
->proc_name
->attr
.pure
14615 && sym
->attr
.in_common
)
14617 gfc_error ("Common block member %qs at %L cannot be an EQUIVALENCE "
14618 "object in the pure procedure %qs",
14619 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14623 /* Shall not be a named constant. */
14624 if (e
->expr_type
== EXPR_CONSTANT
)
14626 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE "
14627 "object", sym
->name
, &e
->where
);
14631 if (e
->ts
.type
== BT_DERIVED
14632 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14635 /* Check that the types correspond correctly:
14637 A numeric sequence structure may be equivalenced to another sequence
14638 structure, an object of default integer type, default real type, double
14639 precision real type, default logical type such that components of the
14640 structure ultimately only become associated to objects of the same
14641 kind. A character sequence structure may be equivalenced to an object
14642 of default character kind or another character sequence structure.
14643 Other objects may be equivalenced only to objects of the same type and
14644 kind parameters. */
14646 /* Identical types are unconditionally OK. */
14647 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14648 goto identical_types
;
14650 last_eq_type
= sequence_type (*last_ts
);
14651 eq_type
= sequence_type (sym
->ts
);
14653 /* Since the pair of objects is not of the same type, mixed or
14654 non-default sequences can be rejected. */
14656 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14657 "statement at %L with different type objects";
14659 && last_eq_type
== SEQ_MIXED
14660 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14661 || (eq_type
== SEQ_MIXED
14662 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14665 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14666 "statement at %L with objects of different type";
14668 && last_eq_type
== SEQ_NONDEFAULT
14669 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14670 || (eq_type
== SEQ_NONDEFAULT
14671 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14674 msg
="Non-CHARACTER object %qs in default CHARACTER "
14675 "EQUIVALENCE statement at %L";
14676 if (last_eq_type
== SEQ_CHARACTER
14677 && eq_type
!= SEQ_CHARACTER
14678 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14681 msg
="Non-NUMERIC object %qs in default NUMERIC "
14682 "EQUIVALENCE statement at %L";
14683 if (last_eq_type
== SEQ_NUMERIC
14684 && eq_type
!= SEQ_NUMERIC
14685 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14690 last_where
= &e
->where
;
14695 /* Shall not be an automatic array. */
14696 if (e
->ref
->type
== REF_ARRAY
14697 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14699 gfc_error ("Array %qs at %L with non-constant bounds cannot be "
14700 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14707 /* Shall not be a structure component. */
14708 if (r
->type
== REF_COMPONENT
)
14710 gfc_error ("Structure component %qs at %L cannot be an "
14711 "EQUIVALENCE object",
14712 r
->u
.c
.component
->name
, &e
->where
);
14716 /* A substring shall not have length zero. */
14717 if (r
->type
== REF_SUBSTRING
)
14719 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14721 gfc_error ("Substring at %L has length zero",
14722 &r
->u
.ss
.start
->where
);
14732 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14735 resolve_fntype (gfc_namespace
*ns
)
14737 gfc_entry_list
*el
;
14740 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14743 /* If there are any entries, ns->proc_name is the entry master
14744 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14746 sym
= ns
->entries
->sym
;
14748 sym
= ns
->proc_name
;
14749 if (sym
->result
== sym
14750 && sym
->ts
.type
== BT_UNKNOWN
14751 && !gfc_set_default_type (sym
, 0, NULL
)
14752 && !sym
->attr
.untyped
)
14754 gfc_error ("Function %qs at %L has no IMPLICIT type",
14755 sym
->name
, &sym
->declared_at
);
14756 sym
->attr
.untyped
= 1;
14759 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14760 && !sym
->attr
.contained
14761 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14762 && gfc_check_symbol_access (sym
))
14764 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function %qs at "
14765 "%L of PRIVATE type %qs", sym
->name
,
14766 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14770 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14772 if (el
->sym
->result
== el
->sym
14773 && el
->sym
->ts
.type
== BT_UNKNOWN
14774 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14775 && !el
->sym
->attr
.untyped
)
14777 gfc_error ("ENTRY %qs at %L has no IMPLICIT type",
14778 el
->sym
->name
, &el
->sym
->declared_at
);
14779 el
->sym
->attr
.untyped
= 1;
14785 /* 12.3.2.1.1 Defined operators. */
14788 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14790 gfc_formal_arglist
*formal
;
14792 if (!sym
->attr
.function
)
14794 gfc_error ("User operator procedure %qs at %L must be a FUNCTION",
14795 sym
->name
, &where
);
14799 if (sym
->ts
.type
== BT_CHARACTER
14800 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14801 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14802 && sym
->result
->ts
.u
.cl
->length
))
14804 gfc_error ("User operator procedure %qs at %L cannot be assumed "
14805 "character length", sym
->name
, &where
);
14809 formal
= gfc_sym_get_dummy_args (sym
);
14810 if (!formal
|| !formal
->sym
)
14812 gfc_error ("User operator procedure %qs at %L must have at least "
14813 "one argument", sym
->name
, &where
);
14817 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14819 gfc_error ("First argument of operator interface at %L must be "
14820 "INTENT(IN)", &where
);
14824 if (formal
->sym
->attr
.optional
)
14826 gfc_error ("First argument of operator interface at %L cannot be "
14827 "optional", &where
);
14831 formal
= formal
->next
;
14832 if (!formal
|| !formal
->sym
)
14835 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14837 gfc_error ("Second argument of operator interface at %L must be "
14838 "INTENT(IN)", &where
);
14842 if (formal
->sym
->attr
.optional
)
14844 gfc_error ("Second argument of operator interface at %L cannot be "
14845 "optional", &where
);
14851 gfc_error ("Operator interface at %L must have, at most, two "
14852 "arguments", &where
);
14860 gfc_resolve_uops (gfc_symtree
*symtree
)
14862 gfc_interface
*itr
;
14864 if (symtree
== NULL
)
14867 gfc_resolve_uops (symtree
->left
);
14868 gfc_resolve_uops (symtree
->right
);
14870 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14871 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14875 /* Examine all of the expressions associated with a program unit,
14876 assign types to all intermediate expressions, make sure that all
14877 assignments are to compatible types and figure out which names
14878 refer to which functions or subroutines. It doesn't check code
14879 block, which is handled by gfc_resolve_code. */
14882 resolve_types (gfc_namespace
*ns
)
14888 gfc_namespace
* old_ns
= gfc_current_ns
;
14890 /* Check that all IMPLICIT types are ok. */
14891 if (!ns
->seen_implicit_none
)
14894 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14895 if (ns
->set_flag
[letter
]
14896 && !resolve_typespec_used (&ns
->default_type
[letter
],
14897 &ns
->implicit_loc
[letter
], NULL
))
14901 gfc_current_ns
= ns
;
14903 resolve_entries (ns
);
14905 resolve_common_vars (ns
->blank_common
.head
, false);
14906 resolve_common_blocks (ns
->common_root
);
14908 resolve_contained_functions (ns
);
14910 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14911 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14912 resolve_formal_arglist (ns
->proc_name
);
14914 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14916 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14917 resolve_charlen (cl
);
14919 gfc_traverse_ns (ns
, resolve_symbol
);
14921 resolve_fntype (ns
);
14923 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14925 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14926 gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
14927 "also be PURE", n
->proc_name
->name
,
14928 &n
->proc_name
->declared_at
);
14934 gfc_do_concurrent_flag
= 0;
14935 gfc_check_interfaces (ns
);
14937 gfc_traverse_ns (ns
, resolve_values
);
14943 for (d
= ns
->data
; d
; d
= d
->next
)
14947 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14949 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14951 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14952 resolve_equivalence (eq
);
14954 /* Warn about unused labels. */
14955 if (warn_unused_label
)
14956 warn_unused_fortran_label (ns
->st_labels
);
14958 gfc_resolve_uops (ns
->uop_root
);
14960 gfc_resolve_omp_declare_simd (ns
);
14962 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
14964 gfc_current_ns
= old_ns
;
14968 /* Call gfc_resolve_code recursively. */
14971 resolve_codes (gfc_namespace
*ns
)
14974 bitmap_obstack old_obstack
;
14976 if (ns
->resolved
== 1)
14979 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14982 gfc_current_ns
= ns
;
14984 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14985 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14988 /* Set to an out of range value. */
14989 current_entry_id
= -1;
14991 old_obstack
= labels_obstack
;
14992 bitmap_obstack_initialize (&labels_obstack
);
14994 gfc_resolve_oacc_declare (ns
);
14995 gfc_resolve_code (ns
->code
, ns
);
14997 bitmap_obstack_release (&labels_obstack
);
14998 labels_obstack
= old_obstack
;
15002 /* This function is called after a complete program unit has been compiled.
15003 Its purpose is to examine all of the expressions associated with a program
15004 unit, assign types to all intermediate expressions, make sure that all
15005 assignments are to compatible types and figure out which names refer to
15006 which functions or subroutines. */
15009 gfc_resolve (gfc_namespace
*ns
)
15011 gfc_namespace
*old_ns
;
15012 code_stack
*old_cs_base
;
15018 old_ns
= gfc_current_ns
;
15019 old_cs_base
= cs_base
;
15021 resolve_types (ns
);
15022 component_assignment_level
= 0;
15023 resolve_codes (ns
);
15025 gfc_current_ns
= old_ns
;
15026 cs_base
= old_cs_base
;
15029 gfc_run_passes (ns
);