1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and gfc_resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code
*head
, *current
;
48 struct code_stack
*prev
;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels
;
57 static code_stack
*cs_base
= NULL
;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag
;
63 int gfc_do_concurrent_flag
;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg
= false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg
= false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag
;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag
= 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr
= false;
84 /* The id of the last entry seen. */
85 static int current_entry_id
;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack
;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument
= false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag
;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
104 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
120 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
125 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type '%s' used at %L",
129 ts
->u
.derived
->name
, where
);
140 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
142 /* Several checks for F08:C1216. */
143 if (ifc
->attr
.procedure
)
145 gfc_error ("Interface '%s' at %L is declared "
146 "in a later PROCEDURE statement", ifc
->name
, where
);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface
*gen
= ifc
->generic
;
154 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
158 gfc_error ("Interface '%s' at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface '%s' at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
170 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
171 ifc
->attr
.intrinsic
= 1;
172 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
174 gfc_error ("Intrinsic procedure '%s' not allowed in "
175 "PROCEDURE statement at %L", ifc
->name
, where
);
178 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
180 gfc_error ("Interface '%s' at %L must be explicit", ifc
->name
, where
);
187 static void resolve_symbol (gfc_symbol
*sym
);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol
*sym
)
195 gfc_symbol
*ifc
= sym
->ts
.interface
;
202 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
203 sym
->name
, &sym
->declared_at
);
206 if (!check_proc_interface (ifc
, &sym
->declared_at
))
209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc
);
213 if (ifc
->attr
.intrinsic
)
214 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
218 sym
->ts
= ifc
->result
->ts
;
223 sym
->ts
.interface
= ifc
;
224 sym
->attr
.function
= ifc
->attr
.function
;
225 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.pure
= ifc
->attr
.pure
;
230 sym
->attr
.elemental
= ifc
->attr
.elemental
;
231 sym
->attr
.dimension
= ifc
->attr
.dimension
;
232 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
233 sym
->attr
.recursive
= ifc
->attr
.recursive
;
234 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
235 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
236 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
237 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
238 /* Copy array spec. */
239 sym
->as
= gfc_copy_array_spec (ifc
->as
);
240 /* Copy char length. */
241 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
243 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
244 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
245 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol
*proc
)
266 gfc_formal_arglist
*f
;
268 bool saved_specification_expr
;
271 if (proc
->result
!= NULL
)
276 if (gfc_elemental (proc
)
277 || sym
->attr
.pointer
|| sym
->attr
.allocatable
278 || (sym
->as
&& sym
->as
->rank
!= 0))
280 proc
->attr
.always_explicit
= 1;
281 sym
->attr
.always_explicit
= 1;
286 for (f
= proc
->formal
; f
; f
= f
->next
)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc
))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "'%s' at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "'%s' at %L is not allowed", proc
->name
,
305 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
306 && !resolve_procedure_interface (sym
))
309 if (strcmp (proc
->name
, sym
->name
) == 0)
311 gfc_error ("Self-referential argument "
312 "'%s' at %L is not allowed", sym
->name
,
317 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
318 resolve_formal_arglist (sym
);
320 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
322 if (sym
->attr
.flavor
== FL_UNKNOWN
)
323 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
327 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
328 && (!sym
->attr
.function
|| sym
->result
== sym
))
329 gfc_set_default_type (sym
, 1, sym
->ns
);
332 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
333 ? CLASS_DATA (sym
)->as
: sym
->as
;
335 saved_specification_expr
= specification_expr
;
336 specification_expr
= true;
337 gfc_resolve_array_spec (as
, 0);
338 specification_expr
= saved_specification_expr
;
340 /* We can't tell if an array with dimension (:) is assumed or deferred
341 shape until we know if it has the pointer or allocatable attributes.
343 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
344 && ((sym
->ts
.type
!= BT_CLASS
345 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
346 || (sym
->ts
.type
== BT_CLASS
347 && !(CLASS_DATA (sym
)->attr
.class_pointer
348 || CLASS_DATA (sym
)->attr
.allocatable
)))
349 && sym
->attr
.flavor
!= FL_PROCEDURE
)
351 as
->type
= AS_ASSUMED_SHAPE
;
352 for (i
= 0; i
< as
->rank
; i
++)
353 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
356 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
357 || (as
&& as
->type
== AS_ASSUMED_RANK
)
358 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
359 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
360 && (CLASS_DATA (sym
)->attr
.class_pointer
361 || CLASS_DATA (sym
)->attr
.allocatable
362 || CLASS_DATA (sym
)->attr
.target
))
363 || sym
->attr
.optional
)
365 proc
->attr
.always_explicit
= 1;
367 proc
->result
->attr
.always_explicit
= 1;
370 /* If the flavor is unknown at this point, it has to be a variable.
371 A procedure specification would have already set the type. */
373 if (sym
->attr
.flavor
== FL_UNKNOWN
)
374 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
383 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
384 "also be PURE", sym
->name
, &sym
->declared_at
);
388 else if (!sym
->attr
.pointer
)
390 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
393 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
394 " of pure function '%s' at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument '%s' of pure function '%s' at %L must "
399 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
403 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
406 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
407 " of pure subroutine '%s' at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
412 "must have its INTENT specified or have the "
413 "VALUE attribute", sym
->name
, proc
->name
,
419 if (proc
->attr
.implicit_pure
)
421 if (sym
->attr
.flavor
== FL_PROCEDURE
)
424 proc
->attr
.implicit_pure
= 0;
426 else if (!sym
->attr
.pointer
)
428 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
430 proc
->attr
.implicit_pure
= 0;
432 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
434 proc
->attr
.implicit_pure
= 0;
438 if (gfc_elemental (proc
))
441 if (sym
->attr
.codimension
442 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
443 && CLASS_DATA (sym
)->attr
.codimension
))
445 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
446 "procedure", sym
->name
, &sym
->declared_at
);
450 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
451 && CLASS_DATA (sym
)->as
))
453 gfc_error ("Argument '%s' of elemental procedure at %L must "
454 "be scalar", sym
->name
, &sym
->declared_at
);
458 if (sym
->attr
.allocatable
459 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->attr
.allocatable
))
462 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
463 "have the ALLOCATABLE attribute", sym
->name
,
468 if (sym
->attr
.pointer
469 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
470 && CLASS_DATA (sym
)->attr
.class_pointer
))
472 gfc_error ("Argument %qs of elemental procedure at %L cannot "
473 "have the POINTER attribute", sym
->name
,
478 if (sym
->attr
.flavor
== FL_PROCEDURE
)
480 gfc_error ("Dummy procedure %qs not allowed in elemental "
481 "procedure %qs at %L", sym
->name
, proc
->name
,
486 /* Fortran 2008 Corrigendum 1, C1290a. */
487 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
489 gfc_error ("Argument %qs of elemental procedure %qs at %L must "
490 "have its INTENT specified or have the VALUE "
491 "attribute", sym
->name
, proc
->name
,
497 /* Each dummy shall be specified to be scalar. */
498 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
502 gfc_error ("Argument %qs of statement function at %L must "
503 "be scalar", sym
->name
, &sym
->declared_at
);
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
510 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
512 gfc_error ("Character-valued argument %qs of statement "
513 "function at %L must have constant length",
514 sym
->name
, &sym
->declared_at
);
524 /* Work function called when searching for symbols that have argument lists
525 associated with them. */
528 find_arglists (gfc_symbol
*sym
)
530 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
531 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
534 resolve_formal_arglist (sym
);
538 /* Given a namespace, resolve all formal argument lists within the namespace.
542 resolve_formal_arglists (gfc_namespace
*ns
)
547 gfc_traverse_ns (ns
, find_arglists
);
552 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
556 /* If this namespace is not a function or an entry master function,
558 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
559 || sym
->attr
.entry_master
)
562 /* Try to find out of what the return type is. */
563 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
565 t
= gfc_set_default_type (sym
->result
, 0, ns
);
567 if (!t
&& !sym
->result
->attr
.untyped
)
569 if (sym
->result
== sym
)
570 gfc_error ("Contained function %qs at %L has no IMPLICIT type",
571 sym
->name
, &sym
->declared_at
);
572 else if (!sym
->result
->attr
.proc_pointer
)
573 gfc_error ("Result %qs of contained function %qs at %L has "
574 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
575 &sym
->result
->declared_at
);
576 sym
->result
->attr
.untyped
= 1;
580 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
581 type, lists the only ways a character length value of * can be used:
582 dummy arguments of procedures, named constants, and function results
583 in external functions. Internal function results and results of module
584 procedures are not on this list, ergo, not permitted. */
586 if (sym
->result
->ts
.type
== BT_CHARACTER
)
588 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
589 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
591 /* See if this is a module-procedure and adapt error message
594 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
595 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
597 gfc_error ("Character-valued %s %qs at %L must not be"
599 module_proc
? _("module procedure")
600 : _("internal function"),
601 sym
->name
, &sym
->declared_at
);
607 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
608 introduce duplicates. */
611 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
613 gfc_formal_arglist
*f
, *new_arglist
;
616 for (; new_args
!= NULL
; new_args
= new_args
->next
)
618 new_sym
= new_args
->sym
;
619 /* See if this arg is already in the formal argument list. */
620 for (f
= proc
->formal
; f
; f
= f
->next
)
622 if (new_sym
== f
->sym
)
629 /* Add a new argument. Argument order is not important. */
630 new_arglist
= gfc_get_formal_arglist ();
631 new_arglist
->sym
= new_sym
;
632 new_arglist
->next
= proc
->formal
;
633 proc
->formal
= new_arglist
;
638 /* Flag the arguments that are not present in all entries. */
641 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
643 gfc_formal_arglist
*f
, *head
;
646 for (f
= proc
->formal
; f
; f
= f
->next
)
651 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
653 if (new_args
->sym
== f
->sym
)
660 f
->sym
->attr
.not_always_present
= 1;
665 /* Resolve alternate entry points. If a symbol has multiple entry points we
666 create a new master symbol for the main routine, and turn the existing
667 symbol into an entry point. */
670 resolve_entries (gfc_namespace
*ns
)
672 gfc_namespace
*old_ns
;
676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
677 static int master_count
= 0;
679 if (ns
->proc_name
== NULL
)
682 /* No need to do anything if this procedure doesn't have alternate entry
687 /* We may already have resolved alternate entry points. */
688 if (ns
->proc_name
->attr
.entry_master
)
691 /* If this isn't a procedure something has gone horribly wrong. */
692 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
694 /* Remember the current namespace. */
695 old_ns
= gfc_current_ns
;
699 /* Add the main entry point to the list of entry points. */
700 el
= gfc_get_entry_list ();
701 el
->sym
= ns
->proc_name
;
703 el
->next
= ns
->entries
;
705 ns
->proc_name
->attr
.entry
= 1;
707 /* If it is a module function, it needs to be in the right namespace
708 so that gfc_get_fake_result_decl can gather up the results. The
709 need for this arose in get_proc_name, where these beasts were
710 left in their own namespace, to keep prior references linked to
711 the entry declaration.*/
712 if (ns
->proc_name
->attr
.function
713 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
716 /* Do the same for entries where the master is not a module
717 procedure. These are retained in the module namespace because
718 of the module procedure declaration. */
719 for (el
= el
->next
; el
; el
= el
->next
)
720 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
721 && el
->sym
->attr
.mod_proc
)
725 /* Add an entry statement for it. */
726 c
= gfc_get_code (EXEC_ENTRY
);
731 /* Create a new symbol for the master function. */
732 /* Give the internal function a unique name (within this file).
733 Also include the function name so the user has some hope of figuring
734 out what is going on. */
735 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
736 master_count
++, ns
->proc_name
->name
);
737 gfc_get_ha_symbol (name
, &proc
);
738 gcc_assert (proc
!= NULL
);
740 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
741 if (ns
->proc_name
->attr
.subroutine
)
742 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
746 gfc_typespec
*ts
, *fts
;
747 gfc_array_spec
*as
, *fas
;
748 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
750 fas
= ns
->entries
->sym
->as
;
751 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
752 fts
= &ns
->entries
->sym
->result
->ts
;
753 if (fts
->type
== BT_UNKNOWN
)
754 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
755 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
757 ts
= &el
->sym
->result
->ts
;
759 as
= as
? as
: el
->sym
->result
->as
;
760 if (ts
->type
== BT_UNKNOWN
)
761 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
763 if (! gfc_compare_types (ts
, fts
)
764 || (el
->sym
->result
->attr
.dimension
765 != ns
->entries
->sym
->result
->attr
.dimension
)
766 || (el
->sym
->result
->attr
.pointer
767 != ns
->entries
->sym
->result
->attr
.pointer
))
769 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
770 && gfc_compare_array_spec (as
, fas
) == 0)
771 gfc_error ("Function %s at %L has entries with mismatched "
772 "array specifications", ns
->entries
->sym
->name
,
773 &ns
->entries
->sym
->declared_at
);
774 /* The characteristics need to match and thus both need to have
775 the same string length, i.e. both len=*, or both len=4.
776 Having both len=<variable> is also possible, but difficult to
777 check at compile time. */
778 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
779 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
780 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
782 && ts
->u
.cl
->length
->expr_type
783 != fts
->u
.cl
->length
->expr_type
)
785 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
786 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
787 fts
->u
.cl
->length
->value
.integer
) != 0)))
788 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
789 "entries returning variables of different "
790 "string lengths", ns
->entries
->sym
->name
,
791 &ns
->entries
->sym
->declared_at
);
796 sym
= ns
->entries
->sym
->result
;
797 /* All result types the same. */
799 if (sym
->attr
.dimension
)
800 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
801 if (sym
->attr
.pointer
)
802 gfc_add_pointer (&proc
->attr
, NULL
);
806 /* Otherwise the result will be passed through a union by
808 proc
->attr
.mixed_entry_master
= 1;
809 for (el
= ns
->entries
; el
; el
= el
->next
)
811 sym
= el
->sym
->result
;
812 if (sym
->attr
.dimension
)
814 if (el
== ns
->entries
)
815 gfc_error ("FUNCTION result %s can't be an array in "
816 "FUNCTION %s at %L", sym
->name
,
817 ns
->entries
->sym
->name
, &sym
->declared_at
);
819 gfc_error ("ENTRY result %s can't be an array in "
820 "FUNCTION %s at %L", sym
->name
,
821 ns
->entries
->sym
->name
, &sym
->declared_at
);
823 else if (sym
->attr
.pointer
)
825 if (el
== ns
->entries
)
826 gfc_error ("FUNCTION result %s can't be a POINTER in "
827 "FUNCTION %s at %L", sym
->name
,
828 ns
->entries
->sym
->name
, &sym
->declared_at
);
830 gfc_error ("ENTRY result %s can't be a POINTER in "
831 "FUNCTION %s at %L", sym
->name
,
832 ns
->entries
->sym
->name
, &sym
->declared_at
);
837 if (ts
->type
== BT_UNKNOWN
)
838 ts
= gfc_get_default_type (sym
->name
, NULL
);
842 if (ts
->kind
== gfc_default_integer_kind
)
846 if (ts
->kind
== gfc_default_real_kind
847 || ts
->kind
== gfc_default_double_kind
)
851 if (ts
->kind
== gfc_default_complex_kind
)
855 if (ts
->kind
== gfc_default_logical_kind
)
859 /* We will issue error elsewhere. */
867 if (el
== ns
->entries
)
868 gfc_error ("FUNCTION result %s can't be of type %s "
869 "in FUNCTION %s at %L", sym
->name
,
870 gfc_typename (ts
), ns
->entries
->sym
->name
,
873 gfc_error ("ENTRY result %s can't be of type %s "
874 "in FUNCTION %s at %L", sym
->name
,
875 gfc_typename (ts
), ns
->entries
->sym
->name
,
882 proc
->attr
.access
= ACCESS_PRIVATE
;
883 proc
->attr
.entry_master
= 1;
885 /* Merge all the entry point arguments. */
886 for (el
= ns
->entries
; el
; el
= el
->next
)
887 merge_argument_lists (proc
, el
->sym
->formal
);
889 /* Check the master formal arguments for any that are not
890 present in all entry points. */
891 for (el
= ns
->entries
; el
; el
= el
->next
)
892 check_argument_lists (proc
, el
->sym
->formal
);
894 /* Use the master function for the function body. */
895 ns
->proc_name
= proc
;
897 /* Finalize the new symbols. */
898 gfc_commit_symbols ();
900 /* Restore the original namespace. */
901 gfc_current_ns
= old_ns
;
905 /* Resolve common variables. */
907 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
909 gfc_symbol
*csym
= sym
;
911 for (; csym
; csym
= csym
->common_next
)
913 if (csym
->value
|| csym
->attr
.data
)
915 if (!csym
->ns
->is_block_data
)
916 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
917 "but only in BLOCK DATA initialization is "
918 "allowed", csym
->name
, &csym
->declared_at
);
919 else if (!named_common
)
920 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
921 "in a blank COMMON but initialization is only "
922 "allowed in named common blocks", csym
->name
,
926 if (UNLIMITED_POLY (csym
))
927 gfc_error_now ("%qs in cannot appear in COMMON at %L "
928 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
930 if (csym
->ts
.type
!= BT_DERIVED
)
933 if (!(csym
->ts
.u
.derived
->attr
.sequence
934 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
935 gfc_error_now ("Derived type variable %qs in COMMON at %L "
936 "has neither the SEQUENCE nor the BIND(C) "
937 "attribute", csym
->name
, &csym
->declared_at
);
938 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
939 gfc_error_now ("Derived type variable %qs in COMMON at %L "
940 "has an ultimate component that is "
941 "allocatable", csym
->name
, &csym
->declared_at
);
942 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
943 gfc_error_now ("Derived type variable %qs in COMMON at %L "
944 "may not have default initializer", csym
->name
,
947 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
948 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
952 /* Resolve common blocks. */
954 resolve_common_blocks (gfc_symtree
*common_root
)
959 if (common_root
== NULL
)
962 if (common_root
->left
)
963 resolve_common_blocks (common_root
->left
);
964 if (common_root
->right
)
965 resolve_common_blocks (common_root
->right
);
967 resolve_common_vars (common_root
->n
.common
->head
, true);
969 /* The common name is a global name - in Fortran 2003 also if it has a
970 C binding name, since Fortran 2008 only the C binding name is a global
972 if (!common_root
->n
.common
->binding_label
973 || gfc_notification_std (GFC_STD_F2008
))
975 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
976 common_root
->n
.common
->name
);
978 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
979 && gsym
->type
== GSYM_COMMON
980 && ((common_root
->n
.common
->binding_label
981 && (!gsym
->binding_label
982 || strcmp (common_root
->n
.common
->binding_label
,
983 gsym
->binding_label
) != 0))
984 || (!common_root
->n
.common
->binding_label
985 && gsym
->binding_label
)))
987 gfc_error_1 ("In Fortran 2003 COMMON '%s' block at %L is a global "
988 "identifier and must thus have the same binding name "
989 "as the same-named COMMON block at %L: %s vs %s",
990 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
992 common_root
->n
.common
->binding_label
993 ? common_root
->n
.common
->binding_label
: "(blank)",
994 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
998 if (gsym
&& gsym
->type
!= GSYM_COMMON
999 && !common_root
->n
.common
->binding_label
)
1001 gfc_error_1 ("COMMON block '%s' at %L uses the same global identifier "
1003 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1007 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1009 gfc_error_1 ("Fortran 2008: COMMON block '%s' with binding label at "
1010 "%L sharing the identifier with global non-COMMON-block "
1011 "entity at %L", common_root
->n
.common
->name
,
1012 &common_root
->n
.common
->where
, &gsym
->where
);
1017 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1018 gsym
->type
= GSYM_COMMON
;
1019 gsym
->where
= common_root
->n
.common
->where
;
1025 if (common_root
->n
.common
->binding_label
)
1027 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1028 common_root
->n
.common
->binding_label
);
1029 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1031 gfc_error_1 ("COMMON block at %L with binding label %s uses the same "
1032 "global identifier as entity at %L",
1033 &common_root
->n
.common
->where
,
1034 common_root
->n
.common
->binding_label
, &gsym
->where
);
1039 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1040 gsym
->type
= GSYM_COMMON
;
1041 gsym
->where
= common_root
->n
.common
->where
;
1047 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1051 if (sym
->attr
.flavor
== FL_PARAMETER
)
1052 gfc_error_1 ("COMMON block '%s' at %L is used as PARAMETER at %L",
1053 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1055 if (sym
->attr
.external
)
1056 gfc_error ("COMMON block %qs at %L can not have the EXTERNAL attribute",
1057 sym
->name
, &common_root
->n
.common
->where
);
1059 if (sym
->attr
.intrinsic
)
1060 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure",
1061 sym
->name
, &common_root
->n
.common
->where
);
1062 else if (sym
->attr
.result
1063 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1064 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1065 "that is also a function result", sym
->name
,
1066 &common_root
->n
.common
->where
);
1067 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1068 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1069 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1070 "that is also a global procedure", sym
->name
,
1071 &common_root
->n
.common
->where
);
1075 /* Resolve contained function types. Because contained functions can call one
1076 another, they have to be worked out before any of the contained procedures
1079 The good news is that if a function doesn't already have a type, the only
1080 way it can get one is through an IMPLICIT type or a RESULT variable, because
1081 by definition contained functions are contained namespace they're contained
1082 in, not in a sibling or parent namespace. */
1085 resolve_contained_functions (gfc_namespace
*ns
)
1087 gfc_namespace
*child
;
1090 resolve_formal_arglists (ns
);
1092 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1094 /* Resolve alternate entry points first. */
1095 resolve_entries (child
);
1097 /* Then check function return types. */
1098 resolve_contained_fntype (child
->proc_name
, child
);
1099 for (el
= child
->entries
; el
; el
= el
->next
)
1100 resolve_contained_fntype (el
->sym
, child
);
1105 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1108 /* Resolve all of the elements of a structure constructor and make sure that
1109 the types are correct. The 'init' flag indicates that the given
1110 constructor is an initializer. */
1113 resolve_structure_cons (gfc_expr
*expr
, int init
)
1115 gfc_constructor
*cons
;
1116 gfc_component
*comp
;
1122 if (expr
->ts
.type
== BT_DERIVED
)
1123 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1125 cons
= gfc_constructor_first (expr
->value
.constructor
);
1127 /* A constructor may have references if it is the result of substituting a
1128 parameter variable. In this case we just pull out the component we
1131 comp
= expr
->ref
->u
.c
.sym
->components
;
1133 comp
= expr
->ts
.u
.derived
->components
;
1135 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1142 if (!gfc_resolve_expr (cons
->expr
))
1148 rank
= comp
->as
? comp
->as
->rank
: 0;
1149 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1150 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1152 gfc_error ("The rank of the element in the structure "
1153 "constructor at %L does not match that of the "
1154 "component (%d/%d)", &cons
->expr
->where
,
1155 cons
->expr
->rank
, rank
);
1159 /* If we don't have the right type, try to convert it. */
1161 if (!comp
->attr
.proc_pointer
&&
1162 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1164 if (strcmp (comp
->name
, "_extends") == 0)
1166 /* Can afford to be brutal with the _extends initializer.
1167 The derived type can get lost because it is PRIVATE
1168 but it is not usage constrained by the standard. */
1169 cons
->expr
->ts
= comp
->ts
;
1171 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1173 gfc_error ("The element in the structure constructor at %L, "
1174 "for pointer component %qs, is %s but should be %s",
1175 &cons
->expr
->where
, comp
->name
,
1176 gfc_basic_typename (cons
->expr
->ts
.type
),
1177 gfc_basic_typename (comp
->ts
.type
));
1182 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1188 /* For strings, the length of the constructor should be the same as
1189 the one of the structure, ensure this if the lengths are known at
1190 compile time and when we are dealing with PARAMETER or structure
1192 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1193 && comp
->ts
.u
.cl
->length
1194 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1195 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1196 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1197 && cons
->expr
->rank
!= 0
1198 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1199 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1201 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1202 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1204 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1205 to make use of the gfc_resolve_character_array_constructor
1206 machinery. The expression is later simplified away to
1207 an array of string literals. */
1208 gfc_expr
*para
= cons
->expr
;
1209 cons
->expr
= gfc_get_expr ();
1210 cons
->expr
->ts
= para
->ts
;
1211 cons
->expr
->where
= para
->where
;
1212 cons
->expr
->expr_type
= EXPR_ARRAY
;
1213 cons
->expr
->rank
= para
->rank
;
1214 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1215 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1216 para
, &cons
->expr
->where
);
1218 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1221 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1222 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1224 gfc_charlen
*cl
, *cl2
;
1227 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1229 if (cl
== cons
->expr
->ts
.u
.cl
)
1237 cl2
->next
= cl
->next
;
1239 gfc_free_expr (cl
->length
);
1243 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1244 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1245 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1246 gfc_resolve_character_array_constructor (cons
->expr
);
1250 if (cons
->expr
->expr_type
== EXPR_NULL
1251 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1252 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1253 || (comp
->ts
.type
== BT_CLASS
1254 && (CLASS_DATA (comp
)->attr
.class_pointer
1255 || CLASS_DATA (comp
)->attr
.allocatable
))))
1258 gfc_error ("The NULL in the structure constructor at %L is "
1259 "being applied to component %qs, which is neither "
1260 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1264 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1266 /* Check procedure pointer interface. */
1267 gfc_symbol
*s2
= NULL
;
1272 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1275 s2
= c2
->ts
.interface
;
1278 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1280 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1281 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1283 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1285 s2
= cons
->expr
->symtree
->n
.sym
;
1286 name
= cons
->expr
->symtree
->n
.sym
->name
;
1289 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1290 err
, sizeof (err
), NULL
, NULL
))
1292 gfc_error ("Interface mismatch for procedure-pointer component "
1293 "%qs in structure constructor at %L: %s",
1294 comp
->name
, &cons
->expr
->where
, err
);
1299 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1300 || cons
->expr
->expr_type
== EXPR_NULL
)
1303 a
= gfc_expr_attr (cons
->expr
);
1305 if (!a
.pointer
&& !a
.target
)
1308 gfc_error ("The element in the structure constructor at %L, "
1309 "for pointer component %qs should be a POINTER or "
1310 "a TARGET", &cons
->expr
->where
, comp
->name
);
1315 /* F08:C461. Additional checks for pointer initialization. */
1319 gfc_error ("Pointer initialization target at %L "
1320 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1325 gfc_error ("Pointer initialization target at %L "
1326 "must have the SAVE attribute", &cons
->expr
->where
);
1330 /* F2003, C1272 (3). */
1331 bool impure
= cons
->expr
->expr_type
== EXPR_VARIABLE
1332 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1333 || gfc_is_coindexed (cons
->expr
));
1334 if (impure
&& gfc_pure (NULL
))
1337 gfc_error ("Invalid expression in the structure constructor for "
1338 "pointer component %qs at %L in PURE procedure",
1339 comp
->name
, &cons
->expr
->where
);
1343 gfc_unset_implicit_pure (NULL
);
1350 /****************** Expression name resolution ******************/
1352 /* Returns 0 if a symbol was not declared with a type or
1353 attribute declaration statement, nonzero otherwise. */
1356 was_declared (gfc_symbol
*sym
)
1362 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1365 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1366 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1367 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1368 || a
.asynchronous
|| a
.codimension
)
1375 /* Determine if a symbol is generic or not. */
1378 generic_sym (gfc_symbol
*sym
)
1382 if (sym
->attr
.generic
||
1383 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1386 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1389 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1396 return generic_sym (s
);
1403 /* Determine if a symbol is specific or not. */
1406 specific_sym (gfc_symbol
*sym
)
1410 if (sym
->attr
.if_source
== IFSRC_IFBODY
1411 || sym
->attr
.proc
== PROC_MODULE
1412 || sym
->attr
.proc
== PROC_INTERNAL
1413 || sym
->attr
.proc
== PROC_ST_FUNCTION
1414 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1415 || sym
->attr
.external
)
1418 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1421 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1423 return (s
== NULL
) ? 0 : specific_sym (s
);
1427 /* Figure out if the procedure is specific, generic or unknown. */
1430 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1434 procedure_kind (gfc_symbol
*sym
)
1436 if (generic_sym (sym
))
1437 return PTYPE_GENERIC
;
1439 if (specific_sym (sym
))
1440 return PTYPE_SPECIFIC
;
1442 return PTYPE_UNKNOWN
;
1445 /* Check references to assumed size arrays. The flag need_full_assumed_size
1446 is nonzero when matching actual arguments. */
1448 static int need_full_assumed_size
= 0;
1451 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1453 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1456 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1457 What should it be? */
1458 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1459 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1460 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1462 gfc_error ("The upper bound in the last dimension must "
1463 "appear in the reference to the assumed size "
1464 "array %qs at %L", sym
->name
, &e
->where
);
1471 /* Look for bad assumed size array references in argument expressions
1472 of elemental and array valued intrinsic procedures. Since this is
1473 called from procedure resolution functions, it only recurses at
1477 resolve_assumed_size_actual (gfc_expr
*e
)
1482 switch (e
->expr_type
)
1485 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1490 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1491 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1502 /* Check a generic procedure, passed as an actual argument, to see if
1503 there is a matching specific name. If none, it is an error, and if
1504 more than one, the reference is ambiguous. */
1506 count_specific_procs (gfc_expr
*e
)
1513 sym
= e
->symtree
->n
.sym
;
1515 for (p
= sym
->generic
; p
; p
= p
->next
)
1516 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1518 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1524 gfc_error ("%qs at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1528 gfc_error ("GENERIC procedure %qs is not allowed as an actual "
1529 "argument at %L", sym
->name
, &e
->where
);
1535 /* See if a call to sym could possibly be a not allowed RECURSION because of
1536 a missing RECURSIVE declaration. This means that either sym is the current
1537 context itself, or sym is the parent of a contained procedure calling its
1538 non-RECURSIVE containing procedure.
1539 This also works if sym is an ENTRY. */
1542 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1544 gfc_symbol
* proc_sym
;
1545 gfc_symbol
* context_proc
;
1546 gfc_namespace
* real_context
;
1548 if (sym
->attr
.flavor
== FL_PROGRAM
1549 || sym
->attr
.flavor
== FL_DERIVED
)
1552 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1554 /* If we've got an ENTRY, find real procedure. */
1555 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1556 proc_sym
= sym
->ns
->entries
->sym
;
1560 /* If sym is RECURSIVE, all is well of course. */
1561 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1564 /* Find the context procedure's "real" symbol if it has entries.
1565 We look for a procedure symbol, so recurse on the parents if we don't
1566 find one (like in case of a BLOCK construct). */
1567 for (real_context
= context
; ; real_context
= real_context
->parent
)
1569 /* We should find something, eventually! */
1570 gcc_assert (real_context
);
1572 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1573 : real_context
->proc_name
);
1575 /* In some special cases, there may not be a proc_name, like for this
1577 real(bad_kind()) function foo () ...
1578 when checking the call to bad_kind ().
1579 In these cases, we simply return here and assume that the
1584 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1588 /* A call from sym's body to itself is recursion, of course. */
1589 if (context_proc
== proc_sym
)
1592 /* The same is true if context is a contained procedure and sym the
1594 if (context_proc
->attr
.contained
)
1596 gfc_symbol
* parent_proc
;
1598 gcc_assert (context
->parent
);
1599 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1600 : context
->parent
->proc_name
);
1602 if (parent_proc
== proc_sym
)
1610 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1611 its typespec and formal argument list. */
1614 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1616 gfc_intrinsic_sym
* isym
= NULL
;
1622 /* Already resolved. */
1623 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1626 /* We already know this one is an intrinsic, so we don't call
1627 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1628 gfc_find_subroutine directly to check whether it is a function or
1631 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1633 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1634 isym
= gfc_intrinsic_subroutine_by_id (id
);
1636 else if (sym
->intmod_sym_id
)
1638 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1639 isym
= gfc_intrinsic_function_by_id (id
);
1641 else if (!sym
->attr
.subroutine
)
1642 isym
= gfc_find_function (sym
->name
);
1644 if (isym
&& !sym
->attr
.subroutine
)
1646 if (sym
->ts
.type
!= BT_UNKNOWN
&& warn_surprising
1647 && !sym
->attr
.implicit_type
)
1648 gfc_warning (OPT_Wsurprising
,
1649 "Type specified for intrinsic function %qs at %L is"
1650 " ignored", sym
->name
, &sym
->declared_at
);
1652 if (!sym
->attr
.function
&&
1653 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1658 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1660 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1662 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type"
1663 " specifier", sym
->name
, &sym
->declared_at
);
1667 if (!sym
->attr
.subroutine
&&
1668 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1673 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym
->name
,
1678 gfc_copy_formal_args_intr (sym
, isym
, NULL
);
1680 sym
->attr
.pure
= isym
->pure
;
1681 sym
->attr
.elemental
= isym
->elemental
;
1683 /* Check it is actually available in the standard settings. */
1684 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1686 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not"
1687 " available in the current standard settings but %s. Use"
1688 " an appropriate -std=* option or enable -fall-intrinsics"
1689 " in order to use it.",
1690 sym
->name
, &sym
->declared_at
, symstd
);
1698 /* Resolve a procedure expression, like passing it to a called procedure or as
1699 RHS for a procedure pointer assignment. */
1702 resolve_procedure_expression (gfc_expr
* expr
)
1706 if (expr
->expr_type
!= EXPR_VARIABLE
)
1708 gcc_assert (expr
->symtree
);
1710 sym
= expr
->symtree
->n
.sym
;
1712 if (sym
->attr
.intrinsic
)
1713 gfc_resolve_intrinsic (sym
, &expr
->where
);
1715 if (sym
->attr
.flavor
!= FL_PROCEDURE
1716 || (sym
->attr
.function
&& sym
->result
== sym
))
1719 /* A non-RECURSIVE procedure that is used as procedure expression within its
1720 own body is in danger of being called recursively. */
1721 if (is_illegal_recursion (sym
, gfc_current_ns
))
1722 gfc_warning ("Non-RECURSIVE procedure %qs at %L is possibly calling"
1723 " itself recursively. Declare it RECURSIVE or use"
1724 " %<-frecursive%>", sym
->name
, &expr
->where
);
1730 /* Resolve an actual argument list. Most of the time, this is just
1731 resolving the expressions in the list.
1732 The exception is that we sometimes have to decide whether arguments
1733 that look like procedure arguments are really simple variable
1737 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1738 bool no_formal_args
)
1741 gfc_symtree
*parent_st
;
1743 int save_need_full_assumed_size
;
1744 bool return_value
= false;
1745 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1748 first_actual_arg
= true;
1750 for (; arg
; arg
= arg
->next
)
1755 /* Check the label is a valid branching target. */
1758 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1760 gfc_error ("Label %d referenced at %L is never defined",
1761 arg
->label
->value
, &arg
->label
->where
);
1765 first_actual_arg
= false;
1769 if (e
->expr_type
== EXPR_VARIABLE
1770 && e
->symtree
->n
.sym
->attr
.generic
1772 && count_specific_procs (e
) != 1)
1775 if (e
->ts
.type
!= BT_PROCEDURE
)
1777 save_need_full_assumed_size
= need_full_assumed_size
;
1778 if (e
->expr_type
!= EXPR_VARIABLE
)
1779 need_full_assumed_size
= 0;
1780 if (!gfc_resolve_expr (e
))
1782 need_full_assumed_size
= save_need_full_assumed_size
;
1786 /* See if the expression node should really be a variable reference. */
1788 sym
= e
->symtree
->n
.sym
;
1790 if (sym
->attr
.flavor
== FL_PROCEDURE
1791 || sym
->attr
.intrinsic
1792 || sym
->attr
.external
)
1796 /* If a procedure is not already determined to be something else
1797 check if it is intrinsic. */
1798 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1799 sym
->attr
.intrinsic
= 1;
1801 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1803 gfc_error ("Statement function %qs at %L is not allowed as an "
1804 "actual argument", sym
->name
, &e
->where
);
1807 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1808 sym
->attr
.subroutine
);
1809 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1811 gfc_error ("Intrinsic %qs at %L is not allowed as an "
1812 "actual argument", sym
->name
, &e
->where
);
1815 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1816 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1818 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is"
1819 " used as actual argument at %L",
1820 sym
->name
, &e
->where
))
1824 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1826 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not "
1827 "allowed as an actual argument at %L", sym
->name
,
1831 /* Check if a generic interface has a specific procedure
1832 with the same name before emitting an error. */
1833 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1836 /* Just in case a specific was found for the expression. */
1837 sym
= e
->symtree
->n
.sym
;
1839 /* If the symbol is the function that names the current (or
1840 parent) scope, then we really have a variable reference. */
1842 if (gfc_is_function_return_value (sym
, sym
->ns
))
1845 /* If all else fails, see if we have a specific intrinsic. */
1846 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1848 gfc_intrinsic_sym
*isym
;
1850 isym
= gfc_find_function (sym
->name
);
1851 if (isym
== NULL
|| !isym
->specific
)
1853 gfc_error ("Unable to find a specific INTRINSIC procedure "
1854 "for the reference %qs at %L", sym
->name
,
1859 sym
->attr
.intrinsic
= 1;
1860 sym
->attr
.function
= 1;
1863 if (!gfc_resolve_expr (e
))
1868 /* See if the name is a module procedure in a parent unit. */
1870 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1873 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1875 gfc_error ("Symbol %qs at %L is ambiguous", sym
->name
, &e
->where
);
1879 if (parent_st
== NULL
)
1882 sym
= parent_st
->n
.sym
;
1883 e
->symtree
= parent_st
; /* Point to the right thing. */
1885 if (sym
->attr
.flavor
== FL_PROCEDURE
1886 || sym
->attr
.intrinsic
1887 || sym
->attr
.external
)
1889 if (!gfc_resolve_expr (e
))
1895 e
->expr_type
= EXPR_VARIABLE
;
1897 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1898 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1899 && CLASS_DATA (sym
)->as
))
1901 e
->rank
= sym
->ts
.type
== BT_CLASS
1902 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1903 e
->ref
= gfc_get_ref ();
1904 e
->ref
->type
= REF_ARRAY
;
1905 e
->ref
->u
.ar
.type
= AR_FULL
;
1906 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1907 ? CLASS_DATA (sym
)->as
: sym
->as
;
1910 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1911 primary.c (match_actual_arg). If above code determines that it
1912 is a variable instead, it needs to be resolved as it was not
1913 done at the beginning of this function. */
1914 save_need_full_assumed_size
= need_full_assumed_size
;
1915 if (e
->expr_type
!= EXPR_VARIABLE
)
1916 need_full_assumed_size
= 0;
1917 if (!gfc_resolve_expr (e
))
1919 need_full_assumed_size
= save_need_full_assumed_size
;
1922 /* Check argument list functions %VAL, %LOC and %REF. There is
1923 nothing to do for %REF. */
1924 if (arg
->name
&& arg
->name
[0] == '%')
1926 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1928 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1930 gfc_error ("By-value argument at %L is not of numeric "
1937 gfc_error ("By-value argument at %L cannot be an array or "
1938 "an array section", &e
->where
);
1942 /* Intrinsics are still PROC_UNKNOWN here. However,
1943 since same file external procedures are not resolvable
1944 in gfortran, it is a good deal easier to leave them to
1946 if (ptype
!= PROC_UNKNOWN
1947 && ptype
!= PROC_DUMMY
1948 && ptype
!= PROC_EXTERNAL
1949 && ptype
!= PROC_MODULE
)
1951 gfc_error ("By-value argument at %L is not allowed "
1952 "in this context", &e
->where
);
1957 /* Statement functions have already been excluded above. */
1958 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1959 && e
->ts
.type
== BT_PROCEDURE
)
1961 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1963 gfc_error ("Passing internal procedure at %L by location "
1964 "not allowed", &e
->where
);
1970 /* Fortran 2008, C1237. */
1971 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1972 && gfc_has_ultimate_pointer (e
))
1974 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1975 "component", &e
->where
);
1979 first_actual_arg
= false;
1982 return_value
= true;
1985 actual_arg
= actual_arg_sav
;
1986 first_actual_arg
= first_actual_arg_sav
;
1988 return return_value
;
1992 /* Do the checks of the actual argument list that are specific to elemental
1993 procedures. If called with c == NULL, we have a function, otherwise if
1994 expr == NULL, we have a subroutine. */
1997 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1999 gfc_actual_arglist
*arg0
;
2000 gfc_actual_arglist
*arg
;
2001 gfc_symbol
*esym
= NULL
;
2002 gfc_intrinsic_sym
*isym
= NULL
;
2004 gfc_intrinsic_arg
*iformal
= NULL
;
2005 gfc_formal_arglist
*eformal
= NULL
;
2006 bool formal_optional
= false;
2007 bool set_by_optional
= false;
2011 /* Is this an elemental procedure? */
2012 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2014 if (expr
->value
.function
.esym
!= NULL
2015 && expr
->value
.function
.esym
->attr
.elemental
)
2017 arg0
= expr
->value
.function
.actual
;
2018 esym
= expr
->value
.function
.esym
;
2020 else if (expr
->value
.function
.isym
!= NULL
2021 && expr
->value
.function
.isym
->elemental
)
2023 arg0
= expr
->value
.function
.actual
;
2024 isym
= expr
->value
.function
.isym
;
2029 else if (c
&& c
->ext
.actual
!= NULL
)
2031 arg0
= c
->ext
.actual
;
2033 if (c
->resolved_sym
)
2034 esym
= c
->resolved_sym
;
2036 esym
= c
->symtree
->n
.sym
;
2039 if (!esym
->attr
.elemental
)
2045 /* The rank of an elemental is the rank of its array argument(s). */
2046 for (arg
= arg0
; arg
; arg
= arg
->next
)
2048 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2050 rank
= arg
->expr
->rank
;
2051 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2052 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2053 set_by_optional
= true;
2055 /* Function specific; set the result rank and shape. */
2059 if (!expr
->shape
&& arg
->expr
->shape
)
2061 expr
->shape
= gfc_get_shape (rank
);
2062 for (i
= 0; i
< rank
; i
++)
2063 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2070 /* If it is an array, it shall not be supplied as an actual argument
2071 to an elemental procedure unless an array of the same rank is supplied
2072 as an actual argument corresponding to a nonoptional dummy argument of
2073 that elemental procedure(12.4.1.5). */
2074 formal_optional
= false;
2076 iformal
= isym
->formal
;
2078 eformal
= esym
->formal
;
2080 for (arg
= arg0
; arg
; arg
= arg
->next
)
2084 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2085 formal_optional
= true;
2086 eformal
= eformal
->next
;
2088 else if (isym
&& iformal
)
2090 if (iformal
->optional
)
2091 formal_optional
= true;
2092 iformal
= iformal
->next
;
2095 formal_optional
= true;
2097 if (pedantic
&& arg
->expr
!= NULL
2098 && arg
->expr
->expr_type
== EXPR_VARIABLE
2099 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2102 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2103 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2105 gfc_warning ("%qs at %L is an array and OPTIONAL; IF IT IS "
2106 "MISSING, it cannot be the actual argument of an "
2107 "ELEMENTAL procedure unless there is a non-optional "
2108 "argument with the same rank (12.4.1.5)",
2109 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2113 for (arg
= arg0
; arg
; arg
= arg
->next
)
2115 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2118 /* Being elemental, the last upper bound of an assumed size array
2119 argument must be present. */
2120 if (resolve_assumed_size_actual (arg
->expr
))
2123 /* Elemental procedure's array actual arguments must conform. */
2126 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2133 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2134 is an array, the intent inout/out variable needs to be also an array. */
2135 if (rank
> 0 && esym
&& expr
== NULL
)
2136 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2137 arg
= arg
->next
, eformal
= eformal
->next
)
2138 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2139 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2140 && arg
->expr
&& arg
->expr
->rank
== 0)
2142 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of "
2143 "ELEMENTAL subroutine %qs is a scalar, but another "
2144 "actual argument is an array", &arg
->expr
->where
,
2145 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2146 : "INOUT", eformal
->sym
->name
, esym
->name
);
2153 /* This function does the checking of references to global procedures
2154 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2155 77 and 95 standards. It checks for a gsymbol for the name, making
2156 one if it does not already exist. If it already exists, then the
2157 reference being resolved must correspond to the type of gsymbol.
2158 Otherwise, the new symbol is equipped with the attributes of the
2159 reference. The corresponding code that is called in creating
2160 global entities is parse.c.
2162 In addition, for all but -std=legacy, the gsymbols are used to
2163 check the interfaces of external procedures from the same file.
2164 The namespace of the gsymbol is resolved and then, once this is
2165 done the interface is checked. */
2169 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2171 if (!gsym_ns
->proc_name
->attr
.recursive
)
2174 if (sym
->ns
== gsym_ns
)
2177 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2184 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2186 if (gsym_ns
->entries
)
2188 gfc_entry_list
*entry
= gsym_ns
->entries
;
2190 for (; entry
; entry
= entry
->next
)
2192 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2194 if (strcmp (gsym_ns
->proc_name
->name
,
2195 sym
->ns
->proc_name
->name
) == 0)
2199 && strcmp (gsym_ns
->proc_name
->name
,
2200 sym
->ns
->parent
->proc_name
->name
) == 0)
2209 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2212 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2214 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2216 for ( ; arg
; arg
= arg
->next
)
2221 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2223 strncpy (errmsg
, _("allocatable argument"), err_len
);
2226 else if (arg
->sym
->attr
.asynchronous
)
2228 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2231 else if (arg
->sym
->attr
.optional
)
2233 strncpy (errmsg
, _("optional argument"), err_len
);
2236 else if (arg
->sym
->attr
.pointer
)
2238 strncpy (errmsg
, _("pointer argument"), err_len
);
2241 else if (arg
->sym
->attr
.target
)
2243 strncpy (errmsg
, _("target argument"), err_len
);
2246 else if (arg
->sym
->attr
.value
)
2248 strncpy (errmsg
, _("value argument"), err_len
);
2251 else if (arg
->sym
->attr
.volatile_
)
2253 strncpy (errmsg
, _("volatile argument"), err_len
);
2256 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2258 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2261 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2263 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2266 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2268 strncpy (errmsg
, _("coarray argument"), err_len
);
2271 else if (false) /* (2d) TODO: parametrized derived type */
2273 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2276 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2278 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2281 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2283 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2286 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2288 /* As assumed-type is unlimited polymorphic (cf. above).
2289 See also TS 29113, Note 6.1. */
2290 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2295 if (sym
->attr
.function
)
2297 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2299 if (res
->attr
.dimension
) /* (3a) */
2301 strncpy (errmsg
, _("array result"), err_len
);
2304 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2306 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2309 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2310 && res
->ts
.u
.cl
->length
2311 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2313 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2318 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
) /* (4) */
2320 strncpy (errmsg
, _("elemental procedure"), err_len
);
2323 else if (sym
->attr
.is_bind_c
) /* (5) */
2325 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2334 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2335 gfc_actual_arglist
**actual
, int sub
)
2339 enum gfc_symbol_type type
;
2342 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2344 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2346 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2347 gfc_global_used (gsym
, where
);
2349 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2350 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2351 && gsym
->type
!= GSYM_UNKNOWN
2352 && !gsym
->binding_label
2354 && gsym
->ns
->resolved
!= -1
2355 && gsym
->ns
->proc_name
2356 && not_in_recursive (sym
, gsym
->ns
)
2357 && not_entry_self_reference (sym
, gsym
->ns
))
2359 gfc_symbol
*def_sym
;
2361 /* Resolve the gsymbol namespace if needed. */
2362 if (!gsym
->ns
->resolved
)
2364 gfc_dt_list
*old_dt_list
;
2365 struct gfc_omp_saved_state old_omp_state
;
2367 /* Stash away derived types so that the backend_decls do not
2369 old_dt_list
= gfc_derived_types
;
2370 gfc_derived_types
= NULL
;
2371 /* And stash away openmp state. */
2372 gfc_omp_save_and_clear_state (&old_omp_state
);
2374 gfc_resolve (gsym
->ns
);
2376 /* Store the new derived types with the global namespace. */
2377 if (gfc_derived_types
)
2378 gsym
->ns
->derived_types
= gfc_derived_types
;
2380 /* Restore the derived types of this namespace. */
2381 gfc_derived_types
= old_dt_list
;
2382 /* And openmp state. */
2383 gfc_omp_restore_state (&old_omp_state
);
2386 /* Make sure that translation for the gsymbol occurs before
2387 the procedure currently being resolved. */
2388 ns
= gfc_global_ns_list
;
2389 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2391 if (ns
->sibling
== gsym
->ns
)
2393 ns
->sibling
= gsym
->ns
->sibling
;
2394 gsym
->ns
->sibling
= gfc_global_ns_list
;
2395 gfc_global_ns_list
= gsym
->ns
;
2400 def_sym
= gsym
->ns
->proc_name
;
2402 /* This can happen if a binding name has been specified. */
2403 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2404 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2406 if (def_sym
->attr
.entry_master
)
2408 gfc_entry_list
*entry
;
2409 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2410 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2412 def_sym
= entry
->sym
;
2417 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2419 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)",
2420 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2421 gfc_typename (&def_sym
->ts
));
2425 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2426 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2428 gfc_error ("Explicit interface required for %qs at %L: %s",
2429 sym
->name
, &sym
->declared_at
, reason
);
2433 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2434 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2435 gfc_errors_to_warnings (true);
2437 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2438 reason
, sizeof(reason
), NULL
, NULL
))
2440 gfc_error ("Interface mismatch in global procedure %qs at %L: %s ",
2441 sym
->name
, &sym
->declared_at
, reason
);
2446 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2447 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2448 gfc_errors_to_warnings (true);
2450 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2451 gfc_procedure_use (def_sym
, actual
, where
);
2455 gfc_errors_to_warnings (false);
2457 if (gsym
->type
== GSYM_UNKNOWN
)
2460 gsym
->where
= *where
;
2467 /************* Function resolution *************/
2469 /* Resolve a function call known to be generic.
2470 Section 14.1.2.4.1. */
2473 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2477 if (sym
->attr
.generic
)
2479 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2482 expr
->value
.function
.name
= s
->name
;
2483 expr
->value
.function
.esym
= s
;
2485 if (s
->ts
.type
!= BT_UNKNOWN
)
2487 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2488 expr
->ts
= s
->result
->ts
;
2491 expr
->rank
= s
->as
->rank
;
2492 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2493 expr
->rank
= s
->result
->as
->rank
;
2495 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2500 /* TODO: Need to search for elemental references in generic
2504 if (sym
->attr
.intrinsic
)
2505 return gfc_intrinsic_func_interface (expr
, 0);
2512 resolve_generic_f (gfc_expr
*expr
)
2516 gfc_interface
*intr
= NULL
;
2518 sym
= expr
->symtree
->n
.sym
;
2522 m
= resolve_generic_f0 (expr
, sym
);
2525 else if (m
== MATCH_ERROR
)
2530 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2531 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2534 if (sym
->ns
->parent
== NULL
)
2536 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2540 if (!generic_sym (sym
))
2544 /* Last ditch attempt. See if the reference is to an intrinsic
2545 that possesses a matching interface. 14.1.2.4 */
2546 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2548 gfc_error ("There is no specific function for the generic %qs "
2549 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2555 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2558 return resolve_structure_cons (expr
, 0);
2561 m
= gfc_intrinsic_func_interface (expr
, 0);
2566 gfc_error ("Generic function %qs at %L is not consistent with a "
2567 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2574 /* Resolve a function call known to be specific. */
2577 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2581 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2583 if (sym
->attr
.dummy
)
2585 sym
->attr
.proc
= PROC_DUMMY
;
2589 sym
->attr
.proc
= PROC_EXTERNAL
;
2593 if (sym
->attr
.proc
== PROC_MODULE
2594 || sym
->attr
.proc
== PROC_ST_FUNCTION
2595 || sym
->attr
.proc
== PROC_INTERNAL
)
2598 if (sym
->attr
.intrinsic
)
2600 m
= gfc_intrinsic_func_interface (expr
, 1);
2604 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible "
2605 "with an intrinsic", sym
->name
, &expr
->where
);
2613 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2616 expr
->ts
= sym
->result
->ts
;
2619 expr
->value
.function
.name
= sym
->name
;
2620 expr
->value
.function
.esym
= sym
;
2621 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->as
)
2622 expr
->rank
= CLASS_DATA (sym
)->as
->rank
;
2623 else if (sym
->as
!= NULL
)
2624 expr
->rank
= sym
->as
->rank
;
2631 resolve_specific_f (gfc_expr
*expr
)
2636 sym
= expr
->symtree
->n
.sym
;
2640 m
= resolve_specific_f0 (sym
, expr
);
2643 if (m
== MATCH_ERROR
)
2646 if (sym
->ns
->parent
== NULL
)
2649 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2655 gfc_error ("Unable to resolve the specific function %qs at %L",
2656 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2662 /* Resolve a procedure call not known to be generic nor specific. */
2665 resolve_unknown_f (gfc_expr
*expr
)
2670 sym
= expr
->symtree
->n
.sym
;
2672 if (sym
->attr
.dummy
)
2674 sym
->attr
.proc
= PROC_DUMMY
;
2675 expr
->value
.function
.name
= sym
->name
;
2679 /* See if we have an intrinsic function reference. */
2681 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2683 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2688 /* The reference is to an external name. */
2690 sym
->attr
.proc
= PROC_EXTERNAL
;
2691 expr
->value
.function
.name
= sym
->name
;
2692 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2694 if (sym
->as
!= NULL
)
2695 expr
->rank
= sym
->as
->rank
;
2697 /* Type of the expression is either the type of the symbol or the
2698 default type of the symbol. */
2701 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2703 if (sym
->ts
.type
!= BT_UNKNOWN
)
2707 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2709 if (ts
->type
== BT_UNKNOWN
)
2711 gfc_error ("Function %qs at %L has no IMPLICIT type",
2712 sym
->name
, &expr
->where
);
2723 /* Return true, if the symbol is an external procedure. */
2725 is_external_proc (gfc_symbol
*sym
)
2727 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2728 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2729 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2730 && !sym
->attr
.proc_pointer
2731 && !sym
->attr
.use_assoc
2739 /* Figure out if a function reference is pure or not. Also set the name
2740 of the function for a potential error message. Return nonzero if the
2741 function is PURE, zero if not. */
2743 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2746 pure_function (gfc_expr
*e
, const char **name
)
2752 if (e
->symtree
!= NULL
2753 && e
->symtree
->n
.sym
!= NULL
2754 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2755 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2757 if (e
->value
.function
.esym
)
2759 pure
= gfc_pure (e
->value
.function
.esym
);
2760 *name
= e
->value
.function
.esym
->name
;
2762 else if (e
->value
.function
.isym
)
2764 pure
= e
->value
.function
.isym
->pure
2765 || e
->value
.function
.isym
->elemental
;
2766 *name
= e
->value
.function
.isym
->name
;
2770 /* Implicit functions are not pure. */
2772 *name
= e
->value
.function
.name
;
2780 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2781 int *f ATTRIBUTE_UNUSED
)
2785 /* Don't bother recursing into other statement functions
2786 since they will be checked individually for purity. */
2787 if (e
->expr_type
!= EXPR_FUNCTION
2789 || e
->symtree
->n
.sym
== sym
2790 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2793 return pure_function (e
, &name
) ? false : true;
2798 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2800 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2804 /* Resolve a function call, which means resolving the arguments, then figuring
2805 out which entity the name refers to. */
2808 resolve_function (gfc_expr
*expr
)
2810 gfc_actual_arglist
*arg
;
2815 procedure_type p
= PROC_INTRINSIC
;
2816 bool no_formal_args
;
2820 sym
= expr
->symtree
->n
.sym
;
2822 /* If this is a procedure pointer component, it has already been resolved. */
2823 if (gfc_is_proc_ptr_comp (expr
))
2826 if (sym
&& sym
->attr
.intrinsic
2827 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2830 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2832 gfc_error ("%qs at %L is not a function", sym
->name
, &expr
->where
);
2836 /* If this ia a deferred TBP with an abstract interface (which may
2837 of course be referenced), expr->value.function.esym will be set. */
2838 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2840 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
2841 sym
->name
, &expr
->where
);
2845 /* Switch off assumed size checking and do this again for certain kinds
2846 of procedure, once the procedure itself is resolved. */
2847 need_full_assumed_size
++;
2849 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2850 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2852 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2853 inquiry_argument
= true;
2854 no_formal_args
= sym
&& is_external_proc (sym
)
2855 && gfc_sym_get_dummy_args (sym
) == NULL
;
2857 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2860 inquiry_argument
= false;
2864 inquiry_argument
= false;
2866 /* Resume assumed_size checking. */
2867 need_full_assumed_size
--;
2869 /* If the procedure is external, check for usage. */
2870 if (sym
&& is_external_proc (sym
))
2871 resolve_global_procedure (sym
, &expr
->where
,
2872 &expr
->value
.function
.actual
, 0);
2874 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2876 && sym
->ts
.u
.cl
->length
== NULL
2878 && !sym
->ts
.deferred
2879 && expr
->value
.function
.esym
== NULL
2880 && !sym
->attr
.contained
)
2882 /* Internal procedures are taken care of in resolve_contained_fntype. */
2883 gfc_error ("Function %qs is declared CHARACTER(*) and cannot "
2884 "be used at %L since it is not a dummy argument",
2885 sym
->name
, &expr
->where
);
2889 /* See if function is already resolved. */
2891 if (expr
->value
.function
.name
!= NULL
2892 || expr
->value
.function
.isym
!= NULL
)
2894 if (expr
->ts
.type
== BT_UNKNOWN
)
2900 /* Apply the rules of section 14.1.2. */
2902 switch (procedure_kind (sym
))
2905 t
= resolve_generic_f (expr
);
2908 case PTYPE_SPECIFIC
:
2909 t
= resolve_specific_f (expr
);
2913 t
= resolve_unknown_f (expr
);
2917 gfc_internal_error ("resolve_function(): bad function type");
2921 /* If the expression is still a function (it might have simplified),
2922 then we check to see if we are calling an elemental function. */
2924 if (expr
->expr_type
!= EXPR_FUNCTION
)
2927 temp
= need_full_assumed_size
;
2928 need_full_assumed_size
= 0;
2930 if (!resolve_elemental_actual (expr
, NULL
))
2933 if (omp_workshare_flag
2934 && expr
->value
.function
.esym
2935 && ! gfc_elemental (expr
->value
.function
.esym
))
2937 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed "
2938 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2943 #define GENERIC_ID expr->value.function.isym->id
2944 else if (expr
->value
.function
.actual
!= NULL
2945 && expr
->value
.function
.isym
!= NULL
2946 && GENERIC_ID
!= GFC_ISYM_LBOUND
2947 && GENERIC_ID
!= GFC_ISYM_LCOBOUND
2948 && GENERIC_ID
!= GFC_ISYM_UCOBOUND
2949 && GENERIC_ID
!= GFC_ISYM_LEN
2950 && GENERIC_ID
!= GFC_ISYM_LOC
2951 && GENERIC_ID
!= GFC_ISYM_C_LOC
2952 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2954 /* Array intrinsics must also have the last upper bound of an
2955 assumed size array argument. UBOUND and SIZE have to be
2956 excluded from the check if the second argument is anything
2959 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2961 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2962 && arg
== expr
->value
.function
.actual
2963 && arg
->next
!= NULL
&& arg
->next
->expr
)
2965 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2968 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2971 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2976 if (arg
->expr
!= NULL
2977 && arg
->expr
->rank
> 0
2978 && resolve_assumed_size_actual (arg
->expr
))
2984 need_full_assumed_size
= temp
;
2987 if (!pure_function (expr
, &name
) && name
)
2991 gfc_error ("Reference to non-PURE function %qs at %L inside a "
2992 "FORALL %s", name
, &expr
->where
,
2993 forall_flag
== 2 ? "mask" : "block");
2996 else if (gfc_do_concurrent_flag
)
2998 gfc_error ("Reference to non-PURE function %qs at %L inside a "
2999 "DO CONCURRENT %s", name
, &expr
->where
,
3000 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
3003 else if (gfc_pure (NULL
))
3005 gfc_error ("Function reference to %qs at %L is to a non-PURE "
3006 "procedure within a PURE procedure", name
, &expr
->where
);
3010 gfc_unset_implicit_pure (NULL
);
3013 /* Functions without the RECURSIVE attribution are not allowed to
3014 * call themselves. */
3015 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3018 esym
= expr
->value
.function
.esym
;
3020 if (is_illegal_recursion (esym
, gfc_current_ns
))
3022 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3023 gfc_error ("ENTRY %qs at %L cannot be called recursively, as"
3024 " function %qs is not RECURSIVE",
3025 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3027 gfc_error ("Function %qs at %L cannot be called recursively, as it"
3028 " is not RECURSIVE", esym
->name
, &expr
->where
);
3034 /* Character lengths of use associated functions may contains references to
3035 symbols not referenced from the current program unit otherwise. Make sure
3036 those symbols are marked as referenced. */
3038 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3039 && expr
->value
.function
.esym
->attr
.use_assoc
)
3041 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3044 /* Make sure that the expression has a typespec that works. */
3045 if (expr
->ts
.type
== BT_UNKNOWN
)
3047 if (expr
->symtree
->n
.sym
->result
3048 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3049 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3050 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3057 /************* Subroutine resolution *************/
3060 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3066 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
3067 sym
->name
, &c
->loc
);
3068 else if (gfc_do_concurrent_flag
)
3069 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
3070 "PURE", sym
->name
, &c
->loc
);
3071 else if (gfc_pure (NULL
))
3072 gfc_error ("Subroutine call to %qs at %L is not PURE", sym
->name
,
3075 gfc_unset_implicit_pure (NULL
);
3080 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3084 if (sym
->attr
.generic
)
3086 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3089 c
->resolved_sym
= s
;
3090 pure_subroutine (c
, s
);
3094 /* TODO: Need to search for elemental references in generic interface. */
3097 if (sym
->attr
.intrinsic
)
3098 return gfc_intrinsic_sub_interface (c
, 0);
3105 resolve_generic_s (gfc_code
*c
)
3110 sym
= c
->symtree
->n
.sym
;
3114 m
= resolve_generic_s0 (c
, sym
);
3117 else if (m
== MATCH_ERROR
)
3121 if (sym
->ns
->parent
== NULL
)
3123 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3127 if (!generic_sym (sym
))
3131 /* Last ditch attempt. See if the reference is to an intrinsic
3132 that possesses a matching interface. 14.1.2.4 */
3133 sym
= c
->symtree
->n
.sym
;
3135 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3137 gfc_error ("There is no specific subroutine for the generic %qs at %L",
3138 sym
->name
, &c
->loc
);
3142 m
= gfc_intrinsic_sub_interface (c
, 0);
3146 gfc_error ("Generic subroutine %qs at %L is not consistent with an "
3147 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3153 /* Resolve a subroutine call known to be specific. */
3156 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3160 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3162 if (sym
->attr
.dummy
)
3164 sym
->attr
.proc
= PROC_DUMMY
;
3168 sym
->attr
.proc
= PROC_EXTERNAL
;
3172 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3175 if (sym
->attr
.intrinsic
)
3177 m
= gfc_intrinsic_sub_interface (c
, 1);
3181 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible "
3182 "with an intrinsic", sym
->name
, &c
->loc
);
3190 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3192 c
->resolved_sym
= sym
;
3193 pure_subroutine (c
, sym
);
3200 resolve_specific_s (gfc_code
*c
)
3205 sym
= c
->symtree
->n
.sym
;
3209 m
= resolve_specific_s0 (c
, sym
);
3212 if (m
== MATCH_ERROR
)
3215 if (sym
->ns
->parent
== NULL
)
3218 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3224 sym
= c
->symtree
->n
.sym
;
3225 gfc_error ("Unable to resolve the specific subroutine %qs at %L",
3226 sym
->name
, &c
->loc
);
3232 /* Resolve a subroutine call not known to be generic nor specific. */
3235 resolve_unknown_s (gfc_code
*c
)
3239 sym
= c
->symtree
->n
.sym
;
3241 if (sym
->attr
.dummy
)
3243 sym
->attr
.proc
= PROC_DUMMY
;
3247 /* See if we have an intrinsic function reference. */
3249 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3251 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3256 /* The reference is to an external name. */
3259 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3261 c
->resolved_sym
= sym
;
3263 pure_subroutine (c
, sym
);
3269 /* Resolve a subroutine call. Although it was tempting to use the same code
3270 for functions, subroutines and functions are stored differently and this
3271 makes things awkward. */
3274 resolve_call (gfc_code
*c
)
3277 procedure_type ptype
= PROC_INTRINSIC
;
3278 gfc_symbol
*csym
, *sym
;
3279 bool no_formal_args
;
3281 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3283 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3285 gfc_error_1 ("'%s' at %L has a type, which is not consistent with "
3286 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3290 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3293 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3294 sym
= st
? st
->n
.sym
: NULL
;
3295 if (sym
&& csym
!= sym
3296 && sym
->ns
== gfc_current_ns
3297 && sym
->attr
.flavor
== FL_PROCEDURE
3298 && sym
->attr
.contained
)
3301 if (csym
->attr
.generic
)
3302 c
->symtree
->n
.sym
= sym
;
3305 csym
= c
->symtree
->n
.sym
;
3309 /* If this ia a deferred TBP, c->expr1 will be set. */
3310 if (!c
->expr1
&& csym
)
3312 if (csym
->attr
.abstract
)
3314 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L",
3315 csym
->name
, &c
->loc
);
3319 /* Subroutines without the RECURSIVE attribution are not allowed to
3321 if (is_illegal_recursion (csym
, gfc_current_ns
))
3323 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3324 gfc_error ("ENTRY %qs at %L cannot be called recursively, "
3325 "as subroutine %qs is not RECURSIVE",
3326 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3328 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, "
3329 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3335 /* Switch off assumed size checking and do this again for certain kinds
3336 of procedure, once the procedure itself is resolved. */
3337 need_full_assumed_size
++;
3340 ptype
= csym
->attr
.proc
;
3342 no_formal_args
= csym
&& is_external_proc (csym
)
3343 && gfc_sym_get_dummy_args (csym
) == NULL
;
3344 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3347 /* Resume assumed_size checking. */
3348 need_full_assumed_size
--;
3350 /* If external, check for usage. */
3351 if (csym
&& is_external_proc (csym
))
3352 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3355 if (c
->resolved_sym
== NULL
)
3357 c
->resolved_isym
= NULL
;
3358 switch (procedure_kind (csym
))
3361 t
= resolve_generic_s (c
);
3364 case PTYPE_SPECIFIC
:
3365 t
= resolve_specific_s (c
);
3369 t
= resolve_unknown_s (c
);
3373 gfc_internal_error ("resolve_subroutine(): bad function type");
3377 /* Some checks of elemental subroutine actual arguments. */
3378 if (!resolve_elemental_actual (NULL
, c
))
3385 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3386 op1->shape and op2->shape are non-NULL return true if their shapes
3387 match. If both op1->shape and op2->shape are non-NULL return false
3388 if their shapes do not match. If either op1->shape or op2->shape is
3389 NULL, return true. */
3392 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3399 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3401 for (i
= 0; i
< op1
->rank
; i
++)
3403 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3405 gfc_error_1 ("Shapes for operands at %L and %L are not conformable",
3406 &op1
->where
, &op2
->where
);
3417 /* Resolve an operator expression node. This can involve replacing the
3418 operation with a user defined function call. */
3421 resolve_operator (gfc_expr
*e
)
3423 gfc_expr
*op1
, *op2
;
3425 bool dual_locus_error
;
3428 /* Resolve all subnodes-- give them types. */
3430 switch (e
->value
.op
.op
)
3433 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3436 /* Fall through... */
3439 case INTRINSIC_UPLUS
:
3440 case INTRINSIC_UMINUS
:
3441 case INTRINSIC_PARENTHESES
:
3442 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3447 /* Typecheck the new node. */
3449 op1
= e
->value
.op
.op1
;
3450 op2
= e
->value
.op
.op2
;
3451 dual_locus_error
= false;
3453 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3454 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3456 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3460 switch (e
->value
.op
.op
)
3462 case INTRINSIC_UPLUS
:
3463 case INTRINSIC_UMINUS
:
3464 if (op1
->ts
.type
== BT_INTEGER
3465 || op1
->ts
.type
== BT_REAL
3466 || op1
->ts
.type
== BT_COMPLEX
)
3472 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3473 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3476 case INTRINSIC_PLUS
:
3477 case INTRINSIC_MINUS
:
3478 case INTRINSIC_TIMES
:
3479 case INTRINSIC_DIVIDE
:
3480 case INTRINSIC_POWER
:
3481 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3483 gfc_type_convert_binary (e
, 1);
3488 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3489 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3490 gfc_typename (&op2
->ts
));
3493 case INTRINSIC_CONCAT
:
3494 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3495 && op1
->ts
.kind
== op2
->ts
.kind
)
3497 e
->ts
.type
= BT_CHARACTER
;
3498 e
->ts
.kind
= op1
->ts
.kind
;
3503 _("Operands of string concatenation operator at %%L are %s/%s"),
3504 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3510 case INTRINSIC_NEQV
:
3511 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3513 e
->ts
.type
= BT_LOGICAL
;
3514 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3515 if (op1
->ts
.kind
< e
->ts
.kind
)
3516 gfc_convert_type (op1
, &e
->ts
, 2);
3517 else if (op2
->ts
.kind
< e
->ts
.kind
)
3518 gfc_convert_type (op2
, &e
->ts
, 2);
3522 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3523 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3524 gfc_typename (&op2
->ts
));
3529 if (op1
->ts
.type
== BT_LOGICAL
)
3531 e
->ts
.type
= BT_LOGICAL
;
3532 e
->ts
.kind
= op1
->ts
.kind
;
3536 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3537 gfc_typename (&op1
->ts
));
3541 case INTRINSIC_GT_OS
:
3543 case INTRINSIC_GE_OS
:
3545 case INTRINSIC_LT_OS
:
3547 case INTRINSIC_LE_OS
:
3548 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3550 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3554 /* Fall through... */
3557 case INTRINSIC_EQ_OS
:
3559 case INTRINSIC_NE_OS
:
3560 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3561 && op1
->ts
.kind
== op2
->ts
.kind
)
3563 e
->ts
.type
= BT_LOGICAL
;
3564 e
->ts
.kind
= gfc_default_logical_kind
;
3568 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3570 gfc_type_convert_binary (e
, 1);
3572 e
->ts
.type
= BT_LOGICAL
;
3573 e
->ts
.kind
= gfc_default_logical_kind
;
3575 if (warn_compare_reals
)
3577 gfc_intrinsic_op op
= e
->value
.op
.op
;
3579 /* Type conversion has made sure that the types of op1 and op2
3580 agree, so it is only necessary to check the first one. */
3581 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3582 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3583 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3587 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3588 msg
= "Equality comparison for %s at %L";
3590 msg
= "Inequality comparison for %s at %L";
3592 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3599 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3601 _("Logicals at %%L must be compared with %s instead of %s"),
3602 (e
->value
.op
.op
== INTRINSIC_EQ
3603 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3604 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3607 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3608 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3609 gfc_typename (&op2
->ts
));
3613 case INTRINSIC_USER
:
3614 if (e
->value
.op
.uop
->op
== NULL
)
3615 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3616 else if (op2
== NULL
)
3617 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3618 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3621 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3622 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3623 gfc_typename (&op2
->ts
));
3624 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3629 case INTRINSIC_PARENTHESES
:
3631 if (e
->ts
.type
== BT_CHARACTER
)
3632 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3636 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3639 /* Deal with arrayness of an operand through an operator. */
3643 switch (e
->value
.op
.op
)
3645 case INTRINSIC_PLUS
:
3646 case INTRINSIC_MINUS
:
3647 case INTRINSIC_TIMES
:
3648 case INTRINSIC_DIVIDE
:
3649 case INTRINSIC_POWER
:
3650 case INTRINSIC_CONCAT
:
3654 case INTRINSIC_NEQV
:
3656 case INTRINSIC_EQ_OS
:
3658 case INTRINSIC_NE_OS
:
3660 case INTRINSIC_GT_OS
:
3662 case INTRINSIC_GE_OS
:
3664 case INTRINSIC_LT_OS
:
3666 case INTRINSIC_LE_OS
:
3668 if (op1
->rank
== 0 && op2
->rank
== 0)
3671 if (op1
->rank
== 0 && op2
->rank
!= 0)
3673 e
->rank
= op2
->rank
;
3675 if (e
->shape
== NULL
)
3676 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3679 if (op1
->rank
!= 0 && op2
->rank
== 0)
3681 e
->rank
= op1
->rank
;
3683 if (e
->shape
== NULL
)
3684 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3687 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3689 if (op1
->rank
== op2
->rank
)
3691 e
->rank
= op1
->rank
;
3692 if (e
->shape
== NULL
)
3694 t
= compare_shapes (op1
, op2
);
3698 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3703 /* Allow higher level expressions to work. */
3706 /* Try user-defined operators, and otherwise throw an error. */
3707 dual_locus_error
= true;
3709 _("Inconsistent ranks for operator at %%L and %%L"));
3716 case INTRINSIC_PARENTHESES
:
3718 case INTRINSIC_UPLUS
:
3719 case INTRINSIC_UMINUS
:
3720 /* Simply copy arrayness attribute */
3721 e
->rank
= op1
->rank
;
3723 if (e
->shape
== NULL
)
3724 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3732 /* Attempt to simplify the expression. */
3735 t
= gfc_simplify_expr (e
, 0);
3736 /* Some calls do not succeed in simplification and return false
3737 even though there is no error; e.g. variable references to
3738 PARAMETER arrays. */
3739 if (!gfc_is_constant_expr (e
))
3747 match m
= gfc_extend_expr (e
);
3750 if (m
== MATCH_ERROR
)
3754 if (dual_locus_error
)
3755 gfc_error (msg
, &op1
->where
, &op2
->where
);
3757 gfc_error (msg
, &e
->where
);
3763 /************** Array resolution subroutines **************/
3766 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3769 /* Compare two integer expressions. */
3772 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3776 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3777 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3780 /* If either of the types isn't INTEGER, we must have
3781 raised an error earlier. */
3783 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3786 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3796 /* Compare an integer expression with an integer. */
3799 compare_bound_int (gfc_expr
*a
, int b
)
3803 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3806 if (a
->ts
.type
!= BT_INTEGER
)
3807 gfc_internal_error ("compare_bound_int(): Bad expression");
3809 i
= mpz_cmp_si (a
->value
.integer
, b
);
3819 /* Compare an integer expression with a mpz_t. */
3822 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3826 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3829 if (a
->ts
.type
!= BT_INTEGER
)
3830 gfc_internal_error ("compare_bound_int(): Bad expression");
3832 i
= mpz_cmp (a
->value
.integer
, b
);
3842 /* Compute the last value of a sequence given by a triplet.
3843 Return 0 if it wasn't able to compute the last value, or if the
3844 sequence if empty, and 1 otherwise. */
3847 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3848 gfc_expr
*stride
, mpz_t last
)
3852 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3853 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3854 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3857 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3858 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3861 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3863 if (compare_bound (start
, end
) == CMP_GT
)
3865 mpz_set (last
, end
->value
.integer
);
3869 if (compare_bound_int (stride
, 0) == CMP_GT
)
3871 /* Stride is positive */
3872 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3877 /* Stride is negative */
3878 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3883 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3884 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3885 mpz_sub (last
, end
->value
.integer
, rem
);
3892 /* Compare a single dimension of an array reference to the array
3896 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3900 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3902 gcc_assert (ar
->stride
[i
] == NULL
);
3903 /* This implies [*] as [*:] and [*:3] are not possible. */
3904 if (ar
->start
[i
] == NULL
)
3906 gcc_assert (ar
->end
[i
] == NULL
);
3911 /* Given start, end and stride values, calculate the minimum and
3912 maximum referenced indexes. */
3914 switch (ar
->dimen_type
[i
])
3917 case DIMEN_THIS_IMAGE
:
3922 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3925 gfc_warning ("Array reference at %L is out of bounds "
3926 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3927 mpz_get_si (ar
->start
[i
]->value
.integer
),
3928 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3930 gfc_warning ("Array reference at %L is out of bounds "
3931 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3932 mpz_get_si (ar
->start
[i
]->value
.integer
),
3933 mpz_get_si (as
->lower
[i
]->value
.integer
),
3937 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3940 gfc_warning ("Array reference at %L is out of bounds "
3941 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3942 mpz_get_si (ar
->start
[i
]->value
.integer
),
3943 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3945 gfc_warning ("Array reference at %L is out of bounds "
3946 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3947 mpz_get_si (ar
->start
[i
]->value
.integer
),
3948 mpz_get_si (as
->upper
[i
]->value
.integer
),
3957 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3958 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3960 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3962 /* Check for zero stride, which is not allowed. */
3963 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3965 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3969 /* if start == len || (stride > 0 && start < len)
3970 || (stride < 0 && start > len),
3971 then the array section contains at least one element. In this
3972 case, there is an out-of-bounds access if
3973 (start < lower || start > upper). */
3974 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3975 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3976 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3977 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3978 && comp_start_end
== CMP_GT
))
3980 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3982 gfc_warning ("Lower array reference at %L is out of bounds "
3983 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3984 mpz_get_si (AR_START
->value
.integer
),
3985 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3988 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3990 gfc_warning ("Lower array reference at %L is out of bounds "
3991 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3992 mpz_get_si (AR_START
->value
.integer
),
3993 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3998 /* If we can compute the highest index of the array section,
3999 then it also has to be between lower and upper. */
4000 mpz_init (last_value
);
4001 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4004 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4006 gfc_warning ("Upper array reference at %L is out of bounds "
4007 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4008 mpz_get_si (last_value
),
4009 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4010 mpz_clear (last_value
);
4013 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4015 gfc_warning ("Upper array reference at %L is out of bounds "
4016 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4017 mpz_get_si (last_value
),
4018 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4019 mpz_clear (last_value
);
4023 mpz_clear (last_value
);
4031 gfc_internal_error ("check_dimension(): Bad array reference");
4038 /* Compare an array reference with an array specification. */
4041 compare_spec_to_ref (gfc_array_ref
*ar
)
4048 /* TODO: Full array sections are only allowed as actual parameters. */
4049 if (as
->type
== AS_ASSUMED_SIZE
4050 && (/*ar->type == AR_FULL
4051 ||*/ (ar
->type
== AR_SECTION
4052 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4054 gfc_error ("Rightmost upper bound of assumed size array section "
4055 "not specified at %L", &ar
->where
);
4059 if (ar
->type
== AR_FULL
)
4062 if (as
->rank
!= ar
->dimen
)
4064 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4065 &ar
->where
, ar
->dimen
, as
->rank
);
4069 /* ar->codimen == 0 is a local array. */
4070 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4072 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4073 &ar
->where
, ar
->codimen
, as
->corank
);
4077 for (i
= 0; i
< as
->rank
; i
++)
4078 if (!check_dimension (i
, ar
, as
))
4081 /* Local access has no coarray spec. */
4082 if (ar
->codimen
!= 0)
4083 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4085 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4086 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4088 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4089 i
+ 1 - as
->rank
, &ar
->where
);
4092 if (!check_dimension (i
, ar
, as
))
4100 /* Resolve one part of an array index. */
4103 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4104 int force_index_integer_kind
)
4111 if (!gfc_resolve_expr (index
))
4114 if (check_scalar
&& index
->rank
!= 0)
4116 gfc_error ("Array index at %L must be scalar", &index
->where
);
4120 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4122 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4123 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4127 if (index
->ts
.type
== BT_REAL
)
4128 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4132 if ((index
->ts
.kind
!= gfc_index_integer_kind
4133 && force_index_integer_kind
)
4134 || index
->ts
.type
!= BT_INTEGER
)
4137 ts
.type
= BT_INTEGER
;
4138 ts
.kind
= gfc_index_integer_kind
;
4140 gfc_convert_type_warn (index
, &ts
, 2, 0);
4146 /* Resolve one part of an array index. */
4149 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4151 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4154 /* Resolve a dim argument to an intrinsic function. */
4157 gfc_resolve_dim_arg (gfc_expr
*dim
)
4162 if (!gfc_resolve_expr (dim
))
4167 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4172 if (dim
->ts
.type
!= BT_INTEGER
)
4174 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4178 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4183 ts
.type
= BT_INTEGER
;
4184 ts
.kind
= gfc_index_integer_kind
;
4186 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4192 /* Given an expression that contains array references, update those array
4193 references to point to the right array specifications. While this is
4194 filled in during matching, this information is difficult to save and load
4195 in a module, so we take care of it here.
4197 The idea here is that the original array reference comes from the
4198 base symbol. We traverse the list of reference structures, setting
4199 the stored reference to references. Component references can
4200 provide an additional array specification. */
4203 find_array_spec (gfc_expr
*e
)
4209 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4210 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4212 as
= e
->symtree
->n
.sym
->as
;
4214 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4219 gfc_internal_error ("find_array_spec(): Missing spec");
4226 c
= ref
->u
.c
.component
;
4227 if (c
->attr
.dimension
)
4230 gfc_internal_error ("find_array_spec(): unused as(1)");
4241 gfc_internal_error ("find_array_spec(): unused as(2)");
4245 /* Resolve an array reference. */
4248 resolve_array_ref (gfc_array_ref
*ar
)
4250 int i
, check_scalar
;
4253 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4255 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4257 /* Do not force gfc_index_integer_kind for the start. We can
4258 do fine with any integer kind. This avoids temporary arrays
4259 created for indexing with a vector. */
4260 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4262 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4264 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4269 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4273 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4277 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4278 if (e
->expr_type
== EXPR_VARIABLE
4279 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4280 ar
->start
[i
] = gfc_get_parentheses (e
);
4284 gfc_error ("Array index at %L is an array of rank %d",
4285 &ar
->c_where
[i
], e
->rank
);
4289 /* Fill in the upper bound, which may be lower than the
4290 specified one for something like a(2:10:5), which is
4291 identical to a(2:7:5). Only relevant for strides not equal
4292 to one. Don't try a division by zero. */
4293 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4294 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4295 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4296 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4300 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4302 if (ar
->end
[i
] == NULL
)
4305 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4307 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4309 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4310 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4312 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4323 if (ar
->type
== AR_FULL
)
4325 if (ar
->as
->rank
== 0)
4326 ar
->type
= AR_ELEMENT
;
4328 /* Make sure array is the same as array(:,:), this way
4329 we don't need to special case all the time. */
4330 ar
->dimen
= ar
->as
->rank
;
4331 for (i
= 0; i
< ar
->dimen
; i
++)
4333 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4335 gcc_assert (ar
->start
[i
] == NULL
);
4336 gcc_assert (ar
->end
[i
] == NULL
);
4337 gcc_assert (ar
->stride
[i
] == NULL
);
4341 /* If the reference type is unknown, figure out what kind it is. */
4343 if (ar
->type
== AR_UNKNOWN
)
4345 ar
->type
= AR_ELEMENT
;
4346 for (i
= 0; i
< ar
->dimen
; i
++)
4347 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4348 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4350 ar
->type
= AR_SECTION
;
4355 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4358 if (ar
->as
->corank
&& ar
->codimen
== 0)
4361 ar
->codimen
= ar
->as
->corank
;
4362 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4363 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4371 resolve_substring (gfc_ref
*ref
)
4373 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4375 if (ref
->u
.ss
.start
!= NULL
)
4377 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4380 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4382 gfc_error ("Substring start index at %L must be of type INTEGER",
4383 &ref
->u
.ss
.start
->where
);
4387 if (ref
->u
.ss
.start
->rank
!= 0)
4389 gfc_error ("Substring start index at %L must be scalar",
4390 &ref
->u
.ss
.start
->where
);
4394 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4395 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4396 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4398 gfc_error ("Substring start index at %L is less than one",
4399 &ref
->u
.ss
.start
->where
);
4404 if (ref
->u
.ss
.end
!= NULL
)
4406 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4409 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4411 gfc_error ("Substring end index at %L must be of type INTEGER",
4412 &ref
->u
.ss
.end
->where
);
4416 if (ref
->u
.ss
.end
->rank
!= 0)
4418 gfc_error ("Substring end index at %L must be scalar",
4419 &ref
->u
.ss
.end
->where
);
4423 if (ref
->u
.ss
.length
!= NULL
4424 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4425 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4426 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4428 gfc_error ("Substring end index at %L exceeds the string length",
4429 &ref
->u
.ss
.start
->where
);
4433 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4434 gfc_integer_kinds
[k
].huge
) == CMP_GT
4435 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4436 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4438 gfc_error ("Substring end index at %L is too large",
4439 &ref
->u
.ss
.end
->where
);
4448 /* This function supplies missing substring charlens. */
4451 gfc_resolve_substring_charlen (gfc_expr
*e
)
4454 gfc_expr
*start
, *end
;
4456 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4457 if (char_ref
->type
== REF_SUBSTRING
)
4463 gcc_assert (char_ref
->next
== NULL
);
4467 if (e
->ts
.u
.cl
->length
)
4468 gfc_free_expr (e
->ts
.u
.cl
->length
);
4469 else if (e
->expr_type
== EXPR_VARIABLE
4470 && e
->symtree
->n
.sym
->attr
.dummy
)
4474 e
->ts
.type
= BT_CHARACTER
;
4475 e
->ts
.kind
= gfc_default_character_kind
;
4478 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4480 if (char_ref
->u
.ss
.start
)
4481 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4483 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4485 if (char_ref
->u
.ss
.end
)
4486 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4487 else if (e
->expr_type
== EXPR_VARIABLE
)
4488 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4494 gfc_free_expr (start
);
4495 gfc_free_expr (end
);
4499 /* Length = (end - start +1). */
4500 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4501 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4502 gfc_get_int_expr (gfc_default_integer_kind
,
4505 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4506 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4508 /* Make sure that the length is simplified. */
4509 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4510 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4514 /* Resolve subtype references. */
4517 resolve_ref (gfc_expr
*expr
)
4519 int current_part_dimension
, n_components
, seen_part_dimension
;
4522 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4523 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4525 find_array_spec (expr
);
4529 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4533 if (!resolve_array_ref (&ref
->u
.ar
))
4541 if (!resolve_substring (ref
))
4546 /* Check constraints on part references. */
4548 current_part_dimension
= 0;
4549 seen_part_dimension
= 0;
4552 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4557 switch (ref
->u
.ar
.type
)
4560 /* Coarray scalar. */
4561 if (ref
->u
.ar
.as
->rank
== 0)
4563 current_part_dimension
= 0;
4568 current_part_dimension
= 1;
4572 current_part_dimension
= 0;
4576 gfc_internal_error ("resolve_ref(): Bad array reference");
4582 if (current_part_dimension
|| seen_part_dimension
)
4585 if (ref
->u
.c
.component
->attr
.pointer
4586 || ref
->u
.c
.component
->attr
.proc_pointer
4587 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4588 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4590 gfc_error ("Component to the right of a part reference "
4591 "with nonzero rank must not have the POINTER "
4592 "attribute at %L", &expr
->where
);
4595 else if (ref
->u
.c
.component
->attr
.allocatable
4596 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4597 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4600 gfc_error ("Component to the right of a part reference "
4601 "with nonzero rank must not have the ALLOCATABLE "
4602 "attribute at %L", &expr
->where
);
4614 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4615 || ref
->next
== NULL
)
4616 && current_part_dimension
4617 && seen_part_dimension
)
4619 gfc_error ("Two or more part references with nonzero rank must "
4620 "not be specified at %L", &expr
->where
);
4624 if (ref
->type
== REF_COMPONENT
)
4626 if (current_part_dimension
)
4627 seen_part_dimension
= 1;
4629 /* reset to make sure */
4630 current_part_dimension
= 0;
4638 /* Given an expression, determine its shape. This is easier than it sounds.
4639 Leaves the shape array NULL if it is not possible to determine the shape. */
4642 expression_shape (gfc_expr
*e
)
4644 mpz_t array
[GFC_MAX_DIMENSIONS
];
4647 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4650 for (i
= 0; i
< e
->rank
; i
++)
4651 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4654 e
->shape
= gfc_get_shape (e
->rank
);
4656 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4661 for (i
--; i
>= 0; i
--)
4662 mpz_clear (array
[i
]);
4666 /* Given a variable expression node, compute the rank of the expression by
4667 examining the base symbol and any reference structures it may have. */
4670 expression_rank (gfc_expr
*e
)
4675 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4676 could lead to serious confusion... */
4677 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4681 if (e
->expr_type
== EXPR_ARRAY
)
4683 /* Constructors can have a rank different from one via RESHAPE(). */
4685 if (e
->symtree
== NULL
)
4691 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4692 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4698 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4700 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4701 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4702 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4704 if (ref
->type
!= REF_ARRAY
)
4707 if (ref
->u
.ar
.type
== AR_FULL
)
4709 rank
= ref
->u
.ar
.as
->rank
;
4713 if (ref
->u
.ar
.type
== AR_SECTION
)
4715 /* Figure out the rank of the section. */
4717 gfc_internal_error ("expression_rank(): Two array specs");
4719 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4720 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4721 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4731 expression_shape (e
);
4736 add_caf_get_intrinsic (gfc_expr
*e
)
4738 gfc_expr
*wrapper
, *tmp_expr
;
4742 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4743 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4748 for (n
= ref
->u
.ar
.dimen
; n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
4749 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
4752 tmp_expr
= XCNEW (gfc_expr
);
4754 wrapper
= gfc_build_intrinsic_call (gfc_current_ns
, GFC_ISYM_CAF_GET
,
4755 "caf_get", tmp_expr
->where
, 1, tmp_expr
);
4756 wrapper
->ts
= e
->ts
;
4757 wrapper
->rank
= e
->rank
;
4759 wrapper
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
4766 remove_caf_get_intrinsic (gfc_expr
*e
)
4768 gcc_assert (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
4769 && e
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
);
4770 gfc_expr
*e2
= e
->value
.function
.actual
->expr
;
4771 e
->value
.function
.actual
->expr
= NULL
;
4772 gfc_free_actual_arglist (e
->value
.function
.actual
);
4773 gfc_free_shape (&e
->shape
, e
->rank
);
4779 /* Resolve a variable expression. */
4782 resolve_variable (gfc_expr
*e
)
4789 if (e
->symtree
== NULL
)
4791 sym
= e
->symtree
->n
.sym
;
4793 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4794 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4795 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4797 if (!actual_arg
|| inquiry_argument
)
4799 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4800 "be used as actual argument", sym
->name
, &e
->where
);
4804 /* TS 29113, 407b. */
4805 else if (e
->ts
.type
== BT_ASSUMED
)
4809 gfc_error ("Assumed-type variable %s at %L may only be used "
4810 "as actual argument", sym
->name
, &e
->where
);
4813 else if (inquiry_argument
&& !first_actual_arg
)
4815 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4816 for all inquiry functions in resolve_function; the reason is
4817 that the function-name resolution happens too late in that
4819 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4820 "an inquiry function shall be the first argument",
4821 sym
->name
, &e
->where
);
4825 /* TS 29113, C535b. */
4826 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4827 && CLASS_DATA (sym
)->as
4828 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4829 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4830 && sym
->as
->type
== AS_ASSUMED_RANK
))
4834 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4835 "actual argument", sym
->name
, &e
->where
);
4838 else if (inquiry_argument
&& !first_actual_arg
)
4840 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4841 for all inquiry functions in resolve_function; the reason is
4842 that the function-name resolution happens too late in that
4844 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4845 "to an inquiry function shall be the first argument",
4846 sym
->name
, &e
->where
);
4851 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4852 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4853 && e
->ref
->next
== NULL
))
4855 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4856 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4859 /* TS 29113, 407b. */
4860 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4861 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4862 && e
->ref
->next
== NULL
))
4864 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4865 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4869 /* TS 29113, C535b. */
4870 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4871 && CLASS_DATA (sym
)->as
4872 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4873 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4874 && sym
->as
->type
== AS_ASSUMED_RANK
))
4876 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4877 && e
->ref
->next
== NULL
))
4879 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4880 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4885 /* If this is an associate-name, it may be parsed with an array reference
4886 in error even though the target is scalar. Fail directly in this case.
4887 TODO Understand why class scalar expressions must be excluded. */
4888 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4890 if (sym
->ts
.type
== BT_CLASS
)
4891 gfc_fix_class_refs (e
);
4892 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4896 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4897 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4899 /* On the other hand, the parser may not have known this is an array;
4900 in this case, we have to add a FULL reference. */
4901 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4903 e
->ref
= gfc_get_ref ();
4904 e
->ref
->type
= REF_ARRAY
;
4905 e
->ref
->u
.ar
.type
= AR_FULL
;
4906 e
->ref
->u
.ar
.dimen
= 0;
4909 if (e
->ref
&& !resolve_ref (e
))
4912 if (sym
->attr
.flavor
== FL_PROCEDURE
4913 && (!sym
->attr
.function
4914 || (sym
->attr
.function
&& sym
->result
4915 && sym
->result
->attr
.proc_pointer
4916 && !sym
->result
->attr
.function
)))
4918 e
->ts
.type
= BT_PROCEDURE
;
4919 goto resolve_procedure
;
4922 if (sym
->ts
.type
!= BT_UNKNOWN
)
4923 gfc_variable_attr (e
, &e
->ts
);
4926 /* Must be a simple variable reference. */
4927 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4932 if (check_assumed_size_reference (sym
, e
))
4935 /* Deal with forward references to entries during gfc_resolve_code, to
4936 satisfy, at least partially, 12.5.2.5. */
4937 if (gfc_current_ns
->entries
4938 && current_entry_id
== sym
->entry_id
4941 && cs_base
->current
->op
!= EXEC_ENTRY
)
4943 gfc_entry_list
*entry
;
4944 gfc_formal_arglist
*formal
;
4946 bool seen
, saved_specification_expr
;
4948 /* If the symbol is a dummy... */
4949 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4951 entry
= gfc_current_ns
->entries
;
4954 /* ...test if the symbol is a parameter of previous entries. */
4955 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4956 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4958 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4965 /* If it has not been seen as a dummy, this is an error. */
4968 if (specification_expr
)
4969 gfc_error ("Variable '%s', used in a specification expression"
4970 ", is referenced at %L before the ENTRY statement "
4971 "in which it is a parameter",
4972 sym
->name
, &cs_base
->current
->loc
);
4974 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4975 "statement in which it is a parameter",
4976 sym
->name
, &cs_base
->current
->loc
);
4981 /* Now do the same check on the specification expressions. */
4982 saved_specification_expr
= specification_expr
;
4983 specification_expr
= true;
4984 if (sym
->ts
.type
== BT_CHARACTER
4985 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4989 for (n
= 0; n
< sym
->as
->rank
; n
++)
4991 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4993 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4996 specification_expr
= saved_specification_expr
;
4999 /* Update the symbol's entry level. */
5000 sym
->entry_id
= current_entry_id
+ 1;
5003 /* If a symbol has been host_associated mark it. This is used latter,
5004 to identify if aliasing is possible via host association. */
5005 if (sym
->attr
.flavor
== FL_VARIABLE
5006 && gfc_current_ns
->parent
5007 && (gfc_current_ns
->parent
== sym
->ns
5008 || (gfc_current_ns
->parent
->parent
5009 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5010 sym
->attr
.host_assoc
= 1;
5013 if (t
&& !resolve_procedure_expression (e
))
5016 /* F2008, C617 and C1229. */
5017 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5018 && gfc_is_coindexed (e
))
5020 gfc_ref
*ref
, *ref2
= NULL
;
5022 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5024 if (ref
->type
== REF_COMPONENT
)
5026 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5030 for ( ; ref
; ref
= ref
->next
)
5031 if (ref
->type
== REF_COMPONENT
)
5034 /* Expression itself is not coindexed object. */
5035 if (ref
&& e
->ts
.type
== BT_CLASS
)
5037 gfc_error ("Polymorphic subobject of coindexed object at %L",
5042 /* Expression itself is coindexed object. */
5046 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5047 for ( ; c
; c
= c
->next
)
5048 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5050 gfc_error ("Coindexed object with polymorphic allocatable "
5051 "subcomponent at %L", &e
->where
);
5059 expression_rank (e
);
5061 if (t
&& gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& gfc_is_coindexed (e
))
5062 add_caf_get_intrinsic (e
);
5068 /* Checks to see that the correct symbol has been host associated.
5069 The only situation where this arises is that in which a twice
5070 contained function is parsed after the host association is made.
5071 Therefore, on detecting this, change the symbol in the expression
5072 and convert the array reference into an actual arglist if the old
5073 symbol is a variable. */
5075 check_host_association (gfc_expr
*e
)
5077 gfc_symbol
*sym
, *old_sym
;
5081 gfc_actual_arglist
*arg
, *tail
= NULL
;
5082 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5084 /* If the expression is the result of substitution in
5085 interface.c(gfc_extend_expr) because there is no way in
5086 which the host association can be wrong. */
5087 if (e
->symtree
== NULL
5088 || e
->symtree
->n
.sym
== NULL
5089 || e
->user_operator
)
5092 old_sym
= e
->symtree
->n
.sym
;
5094 if (gfc_current_ns
->parent
5095 && old_sym
->ns
!= gfc_current_ns
)
5097 /* Use the 'USE' name so that renamed module symbols are
5098 correctly handled. */
5099 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5101 if (sym
&& old_sym
!= sym
5102 && sym
->ts
.type
== old_sym
->ts
.type
5103 && sym
->attr
.flavor
== FL_PROCEDURE
5104 && sym
->attr
.contained
)
5106 /* Clear the shape, since it might not be valid. */
5107 gfc_free_shape (&e
->shape
, e
->rank
);
5109 /* Give the expression the right symtree! */
5110 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5111 gcc_assert (st
!= NULL
);
5113 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5114 || e
->expr_type
== EXPR_FUNCTION
)
5116 /* Original was function so point to the new symbol, since
5117 the actual argument list is already attached to the
5119 e
->value
.function
.esym
= NULL
;
5124 /* Original was variable so convert array references into
5125 an actual arglist. This does not need any checking now
5126 since resolve_function will take care of it. */
5127 e
->value
.function
.actual
= NULL
;
5128 e
->expr_type
= EXPR_FUNCTION
;
5131 /* Ambiguity will not arise if the array reference is not
5132 the last reference. */
5133 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5134 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5137 gcc_assert (ref
->type
== REF_ARRAY
);
5139 /* Grab the start expressions from the array ref and
5140 copy them into actual arguments. */
5141 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5143 arg
= gfc_get_actual_arglist ();
5144 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5145 if (e
->value
.function
.actual
== NULL
)
5146 tail
= e
->value
.function
.actual
= arg
;
5154 /* Dump the reference list and set the rank. */
5155 gfc_free_ref_list (e
->ref
);
5157 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5160 gfc_resolve_expr (e
);
5164 /* This might have changed! */
5165 return e
->expr_type
== EXPR_FUNCTION
;
5170 gfc_resolve_character_operator (gfc_expr
*e
)
5172 gfc_expr
*op1
= e
->value
.op
.op1
;
5173 gfc_expr
*op2
= e
->value
.op
.op2
;
5174 gfc_expr
*e1
= NULL
;
5175 gfc_expr
*e2
= NULL
;
5177 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5179 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5180 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5181 else if (op1
->expr_type
== EXPR_CONSTANT
)
5182 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5183 op1
->value
.character
.length
);
5185 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5186 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5187 else if (op2
->expr_type
== EXPR_CONSTANT
)
5188 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5189 op2
->value
.character
.length
);
5191 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5201 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5202 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5203 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5204 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5205 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5211 /* Ensure that an character expression has a charlen and, if possible, a
5212 length expression. */
5215 fixup_charlen (gfc_expr
*e
)
5217 /* The cases fall through so that changes in expression type and the need
5218 for multiple fixes are picked up. In all circumstances, a charlen should
5219 be available for the middle end to hang a backend_decl on. */
5220 switch (e
->expr_type
)
5223 gfc_resolve_character_operator (e
);
5226 if (e
->expr_type
== EXPR_ARRAY
)
5227 gfc_resolve_character_array_constructor (e
);
5229 case EXPR_SUBSTRING
:
5230 if (!e
->ts
.u
.cl
&& e
->ref
)
5231 gfc_resolve_substring_charlen (e
);
5235 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5242 /* Update an actual argument to include the passed-object for type-bound
5243 procedures at the right position. */
5245 static gfc_actual_arglist
*
5246 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5249 gcc_assert (argpos
> 0);
5253 gfc_actual_arglist
* result
;
5255 result
= gfc_get_actual_arglist ();
5259 result
->name
= name
;
5265 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5267 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5272 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5275 extract_compcall_passed_object (gfc_expr
* e
)
5279 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5281 if (e
->value
.compcall
.base_object
)
5282 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5285 po
= gfc_get_expr ();
5286 po
->expr_type
= EXPR_VARIABLE
;
5287 po
->symtree
= e
->symtree
;
5288 po
->ref
= gfc_copy_ref (e
->ref
);
5289 po
->where
= e
->where
;
5292 if (!gfc_resolve_expr (po
))
5299 /* Update the arglist of an EXPR_COMPCALL expression to include the
5303 update_compcall_arglist (gfc_expr
* e
)
5306 gfc_typebound_proc
* tbp
;
5308 tbp
= e
->value
.compcall
.tbp
;
5313 po
= extract_compcall_passed_object (e
);
5317 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5323 gcc_assert (tbp
->pass_arg_num
> 0);
5324 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5332 /* Extract the passed object from a PPC call (a copy of it). */
5335 extract_ppc_passed_object (gfc_expr
*e
)
5340 po
= gfc_get_expr ();
5341 po
->expr_type
= EXPR_VARIABLE
;
5342 po
->symtree
= e
->symtree
;
5343 po
->ref
= gfc_copy_ref (e
->ref
);
5344 po
->where
= e
->where
;
5346 /* Remove PPC reference. */
5348 while ((*ref
)->next
)
5349 ref
= &(*ref
)->next
;
5350 gfc_free_ref_list (*ref
);
5353 if (!gfc_resolve_expr (po
))
5360 /* Update the actual arglist of a procedure pointer component to include the
5364 update_ppc_arglist (gfc_expr
* e
)
5368 gfc_typebound_proc
* tb
;
5370 ppc
= gfc_get_proc_ptr_comp (e
);
5378 else if (tb
->nopass
)
5381 po
= extract_ppc_passed_object (e
);
5388 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5393 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5395 gfc_error ("Base object for procedure-pointer component call at %L is of"
5396 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5400 gcc_assert (tb
->pass_arg_num
> 0);
5401 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5409 /* Check that the object a TBP is called on is valid, i.e. it must not be
5410 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5413 check_typebound_baseobject (gfc_expr
* e
)
5416 bool return_value
= false;
5418 base
= extract_compcall_passed_object (e
);
5422 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5424 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5428 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5430 gfc_error ("Base object for type-bound procedure call at %L is of"
5431 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5435 /* F08:C1230. If the procedure called is NOPASS,
5436 the base object must be scalar. */
5437 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5439 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5440 " be scalar", &e
->where
);
5444 return_value
= true;
5447 gfc_free_expr (base
);
5448 return return_value
;
5452 /* Resolve a call to a type-bound procedure, either function or subroutine,
5453 statically from the data in an EXPR_COMPCALL expression. The adapted
5454 arglist and the target-procedure symtree are returned. */
5457 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5458 gfc_actual_arglist
** actual
)
5460 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5461 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5463 /* Update the actual arglist for PASS. */
5464 if (!update_compcall_arglist (e
))
5467 *actual
= e
->value
.compcall
.actual
;
5468 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5470 gfc_free_ref_list (e
->ref
);
5472 e
->value
.compcall
.actual
= NULL
;
5474 /* If we find a deferred typebound procedure, check for derived types
5475 that an overriding typebound procedure has not been missed. */
5476 if (e
->value
.compcall
.name
5477 && !e
->value
.compcall
.tbp
->non_overridable
5478 && e
->value
.compcall
.base_object
5479 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5482 gfc_symbol
*derived
;
5484 /* Use the derived type of the base_object. */
5485 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5488 /* If necessary, go through the inheritance chain. */
5489 while (!st
&& derived
)
5491 /* Look for the typebound procedure 'name'. */
5492 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5493 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5494 e
->value
.compcall
.name
);
5496 derived
= gfc_get_derived_super_type (derived
);
5499 /* Now find the specific name in the derived type namespace. */
5500 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5501 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5502 derived
->ns
, 1, &st
);
5510 /* Get the ultimate declared type from an expression. In addition,
5511 return the last class/derived type reference and the copy of the
5512 reference list. If check_types is set true, derived types are
5513 identified as well as class references. */
5515 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5516 gfc_expr
*e
, bool check_types
)
5518 gfc_symbol
*declared
;
5525 *new_ref
= gfc_copy_ref (e
->ref
);
5527 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5529 if (ref
->type
!= REF_COMPONENT
)
5532 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5533 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5534 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5536 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5542 if (declared
== NULL
)
5543 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5549 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5550 which of the specific bindings (if any) matches the arglist and transform
5551 the expression into a call of that binding. */
5554 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5556 gfc_typebound_proc
* genproc
;
5557 const char* genname
;
5559 gfc_symbol
*derived
;
5561 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5562 genname
= e
->value
.compcall
.name
;
5563 genproc
= e
->value
.compcall
.tbp
;
5565 if (!genproc
->is_generic
)
5568 /* Try the bindings on this type and in the inheritance hierarchy. */
5569 for (; genproc
; genproc
= genproc
->overridden
)
5573 gcc_assert (genproc
->is_generic
);
5574 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5577 gfc_actual_arglist
* args
;
5580 gcc_assert (g
->specific
);
5582 if (g
->specific
->error
)
5585 target
= g
->specific
->u
.specific
->n
.sym
;
5587 /* Get the right arglist by handling PASS/NOPASS. */
5588 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5589 if (!g
->specific
->nopass
)
5592 po
= extract_compcall_passed_object (e
);
5595 gfc_free_actual_arglist (args
);
5599 gcc_assert (g
->specific
->pass_arg_num
> 0);
5600 gcc_assert (!g
->specific
->error
);
5601 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5602 g
->specific
->pass_arg
);
5604 resolve_actual_arglist (args
, target
->attr
.proc
,
5605 is_external_proc (target
)
5606 && gfc_sym_get_dummy_args (target
) == NULL
);
5608 /* Check if this arglist matches the formal. */
5609 matches
= gfc_arglist_matches_symbol (&args
, target
);
5611 /* Clean up and break out of the loop if we've found it. */
5612 gfc_free_actual_arglist (args
);
5615 e
->value
.compcall
.tbp
= g
->specific
;
5616 genname
= g
->specific_st
->name
;
5617 /* Pass along the name for CLASS methods, where the vtab
5618 procedure pointer component has to be referenced. */
5626 /* Nothing matching found! */
5627 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5628 " '%s' at %L", genname
, &e
->where
);
5632 /* Make sure that we have the right specific instance for the name. */
5633 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5635 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5637 e
->value
.compcall
.tbp
= st
->n
.tb
;
5643 /* Resolve a call to a type-bound subroutine. */
5646 resolve_typebound_call (gfc_code
* c
, const char **name
)
5648 gfc_actual_arglist
* newactual
;
5649 gfc_symtree
* target
;
5651 /* Check that's really a SUBROUTINE. */
5652 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5654 gfc_error ("'%s' at %L should be a SUBROUTINE",
5655 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5659 if (!check_typebound_baseobject (c
->expr1
))
5662 /* Pass along the name for CLASS methods, where the vtab
5663 procedure pointer component has to be referenced. */
5665 *name
= c
->expr1
->value
.compcall
.name
;
5667 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5670 /* Transform into an ordinary EXEC_CALL for now. */
5672 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5675 c
->ext
.actual
= newactual
;
5676 c
->symtree
= target
;
5677 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5679 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5681 gfc_free_expr (c
->expr1
);
5682 c
->expr1
= gfc_get_expr ();
5683 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5684 c
->expr1
->symtree
= target
;
5685 c
->expr1
->where
= c
->loc
;
5687 return resolve_call (c
);
5691 /* Resolve a component-call expression. */
5693 resolve_compcall (gfc_expr
* e
, const char **name
)
5695 gfc_actual_arglist
* newactual
;
5696 gfc_symtree
* target
;
5698 /* Check that's really a FUNCTION. */
5699 if (!e
->value
.compcall
.tbp
->function
)
5701 gfc_error ("'%s' at %L should be a FUNCTION",
5702 e
->value
.compcall
.name
, &e
->where
);
5706 /* These must not be assign-calls! */
5707 gcc_assert (!e
->value
.compcall
.assign
);
5709 if (!check_typebound_baseobject (e
))
5712 /* Pass along the name for CLASS methods, where the vtab
5713 procedure pointer component has to be referenced. */
5715 *name
= e
->value
.compcall
.name
;
5717 if (!resolve_typebound_generic_call (e
, name
))
5719 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5721 /* Take the rank from the function's symbol. */
5722 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5723 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5725 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5726 arglist to the TBP's binding target. */
5728 if (!resolve_typebound_static (e
, &target
, &newactual
))
5731 e
->value
.function
.actual
= newactual
;
5732 e
->value
.function
.name
= NULL
;
5733 e
->value
.function
.esym
= target
->n
.sym
;
5734 e
->value
.function
.isym
= NULL
;
5735 e
->symtree
= target
;
5736 e
->ts
= target
->n
.sym
->ts
;
5737 e
->expr_type
= EXPR_FUNCTION
;
5739 /* Resolution is not necessary if this is a class subroutine; this
5740 function only has to identify the specific proc. Resolution of
5741 the call will be done next in resolve_typebound_call. */
5742 return gfc_resolve_expr (e
);
5746 static bool resolve_fl_derived (gfc_symbol
*sym
);
5749 /* Resolve a typebound function, or 'method'. First separate all
5750 the non-CLASS references by calling resolve_compcall directly. */
5753 resolve_typebound_function (gfc_expr
* e
)
5755 gfc_symbol
*declared
;
5767 /* Deal with typebound operators for CLASS objects. */
5768 expr
= e
->value
.compcall
.base_object
;
5769 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5770 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5772 /* If the base_object is not a variable, the corresponding actual
5773 argument expression must be stored in e->base_expression so
5774 that the corresponding tree temporary can be used as the base
5775 object in gfc_conv_procedure_call. */
5776 if (expr
->expr_type
!= EXPR_VARIABLE
)
5778 gfc_actual_arglist
*args
;
5780 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5782 if (expr
== args
->expr
)
5787 /* Since the typebound operators are generic, we have to ensure
5788 that any delays in resolution are corrected and that the vtab
5791 declared
= ts
.u
.derived
;
5792 c
= gfc_find_component (declared
, "_vptr", true, true);
5793 if (c
->ts
.u
.derived
== NULL
)
5794 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5796 if (!resolve_compcall (e
, &name
))
5799 /* Use the generic name if it is there. */
5800 name
= name
? name
: e
->value
.function
.esym
->name
;
5801 e
->symtree
= expr
->symtree
;
5802 e
->ref
= gfc_copy_ref (expr
->ref
);
5803 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5805 /* Trim away the extraneous references that emerge from nested
5806 use of interface.c (extend_expr). */
5807 if (class_ref
&& class_ref
->next
)
5809 gfc_free_ref_list (class_ref
->next
);
5810 class_ref
->next
= NULL
;
5812 else if (e
->ref
&& !class_ref
)
5814 gfc_free_ref_list (e
->ref
);
5818 gfc_add_vptr_component (e
);
5819 gfc_add_component_ref (e
, name
);
5820 e
->value
.function
.esym
= NULL
;
5821 if (expr
->expr_type
!= EXPR_VARIABLE
)
5822 e
->base_expr
= expr
;
5827 return resolve_compcall (e
, NULL
);
5829 if (!resolve_ref (e
))
5832 /* Get the CLASS declared type. */
5833 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5835 if (!resolve_fl_derived (declared
))
5838 /* Weed out cases of the ultimate component being a derived type. */
5839 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5840 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5842 gfc_free_ref_list (new_ref
);
5843 return resolve_compcall (e
, NULL
);
5846 c
= gfc_find_component (declared
, "_data", true, true);
5847 declared
= c
->ts
.u
.derived
;
5849 /* Treat the call as if it is a typebound procedure, in order to roll
5850 out the correct name for the specific function. */
5851 if (!resolve_compcall (e
, &name
))
5853 gfc_free_ref_list (new_ref
);
5860 /* Convert the expression to a procedure pointer component call. */
5861 e
->value
.function
.esym
= NULL
;
5867 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5868 gfc_add_vptr_component (e
);
5869 gfc_add_component_ref (e
, name
);
5871 /* Recover the typespec for the expression. This is really only
5872 necessary for generic procedures, where the additional call
5873 to gfc_add_component_ref seems to throw the collection of the
5874 correct typespec. */
5878 gfc_free_ref_list (new_ref
);
5883 /* Resolve a typebound subroutine, or 'method'. First separate all
5884 the non-CLASS references by calling resolve_typebound_call
5888 resolve_typebound_subroutine (gfc_code
*code
)
5890 gfc_symbol
*declared
;
5900 st
= code
->expr1
->symtree
;
5902 /* Deal with typebound operators for CLASS objects. */
5903 expr
= code
->expr1
->value
.compcall
.base_object
;
5904 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5905 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5907 /* If the base_object is not a variable, the corresponding actual
5908 argument expression must be stored in e->base_expression so
5909 that the corresponding tree temporary can be used as the base
5910 object in gfc_conv_procedure_call. */
5911 if (expr
->expr_type
!= EXPR_VARIABLE
)
5913 gfc_actual_arglist
*args
;
5915 args
= code
->expr1
->value
.function
.actual
;
5916 for (; args
; args
= args
->next
)
5917 if (expr
== args
->expr
)
5921 /* Since the typebound operators are generic, we have to ensure
5922 that any delays in resolution are corrected and that the vtab
5924 declared
= expr
->ts
.u
.derived
;
5925 c
= gfc_find_component (declared
, "_vptr", true, true);
5926 if (c
->ts
.u
.derived
== NULL
)
5927 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5929 if (!resolve_typebound_call (code
, &name
))
5932 /* Use the generic name if it is there. */
5933 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5934 code
->expr1
->symtree
= expr
->symtree
;
5935 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5937 /* Trim away the extraneous references that emerge from nested
5938 use of interface.c (extend_expr). */
5939 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5940 if (class_ref
&& class_ref
->next
)
5942 gfc_free_ref_list (class_ref
->next
);
5943 class_ref
->next
= NULL
;
5945 else if (code
->expr1
->ref
&& !class_ref
)
5947 gfc_free_ref_list (code
->expr1
->ref
);
5948 code
->expr1
->ref
= NULL
;
5951 /* Now use the procedure in the vtable. */
5952 gfc_add_vptr_component (code
->expr1
);
5953 gfc_add_component_ref (code
->expr1
, name
);
5954 code
->expr1
->value
.function
.esym
= NULL
;
5955 if (expr
->expr_type
!= EXPR_VARIABLE
)
5956 code
->expr1
->base_expr
= expr
;
5961 return resolve_typebound_call (code
, NULL
);
5963 if (!resolve_ref (code
->expr1
))
5966 /* Get the CLASS declared type. */
5967 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5969 /* Weed out cases of the ultimate component being a derived type. */
5970 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5971 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5973 gfc_free_ref_list (new_ref
);
5974 return resolve_typebound_call (code
, NULL
);
5977 if (!resolve_typebound_call (code
, &name
))
5979 gfc_free_ref_list (new_ref
);
5982 ts
= code
->expr1
->ts
;
5986 /* Convert the expression to a procedure pointer component call. */
5987 code
->expr1
->value
.function
.esym
= NULL
;
5988 code
->expr1
->symtree
= st
;
5991 code
->expr1
->ref
= new_ref
;
5993 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5994 gfc_add_vptr_component (code
->expr1
);
5995 gfc_add_component_ref (code
->expr1
, name
);
5997 /* Recover the typespec for the expression. This is really only
5998 necessary for generic procedures, where the additional call
5999 to gfc_add_component_ref seems to throw the collection of the
6000 correct typespec. */
6001 code
->expr1
->ts
= ts
;
6004 gfc_free_ref_list (new_ref
);
6010 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6013 resolve_ppc_call (gfc_code
* c
)
6015 gfc_component
*comp
;
6017 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6018 gcc_assert (comp
!= NULL
);
6020 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6021 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6023 if (!comp
->attr
.subroutine
)
6024 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6026 if (!resolve_ref (c
->expr1
))
6029 if (!update_ppc_arglist (c
->expr1
))
6032 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6034 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6035 !(comp
->ts
.interface
6036 && comp
->ts
.interface
->formal
)))
6039 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6045 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6048 resolve_expr_ppc (gfc_expr
* e
)
6050 gfc_component
*comp
;
6052 comp
= gfc_get_proc_ptr_comp (e
);
6053 gcc_assert (comp
!= NULL
);
6055 /* Convert to EXPR_FUNCTION. */
6056 e
->expr_type
= EXPR_FUNCTION
;
6057 e
->value
.function
.isym
= NULL
;
6058 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6060 if (comp
->as
!= NULL
)
6061 e
->rank
= comp
->as
->rank
;
6063 if (!comp
->attr
.function
)
6064 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6066 if (!resolve_ref (e
))
6069 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6070 !(comp
->ts
.interface
6071 && comp
->ts
.interface
->formal
)))
6074 if (!update_ppc_arglist (e
))
6077 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6084 gfc_is_expandable_expr (gfc_expr
*e
)
6086 gfc_constructor
*con
;
6088 if (e
->expr_type
== EXPR_ARRAY
)
6090 /* Traverse the constructor looking for variables that are flavor
6091 parameter. Parameters must be expanded since they are fully used at
6093 con
= gfc_constructor_first (e
->value
.constructor
);
6094 for (; con
; con
= gfc_constructor_next (con
))
6096 if (con
->expr
->expr_type
== EXPR_VARIABLE
6097 && con
->expr
->symtree
6098 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6099 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6101 if (con
->expr
->expr_type
== EXPR_ARRAY
6102 && gfc_is_expandable_expr (con
->expr
))
6110 /* Resolve an expression. That is, make sure that types of operands agree
6111 with their operators, intrinsic operators are converted to function calls
6112 for overloaded types and unresolved function references are resolved. */
6115 gfc_resolve_expr (gfc_expr
*e
)
6118 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6123 /* inquiry_argument only applies to variables. */
6124 inquiry_save
= inquiry_argument
;
6125 actual_arg_save
= actual_arg
;
6126 first_actual_arg_save
= first_actual_arg
;
6128 if (e
->expr_type
!= EXPR_VARIABLE
)
6130 inquiry_argument
= false;
6132 first_actual_arg
= false;
6135 switch (e
->expr_type
)
6138 t
= resolve_operator (e
);
6144 if (check_host_association (e
))
6145 t
= resolve_function (e
);
6147 t
= resolve_variable (e
);
6149 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6150 && e
->ref
->type
!= REF_SUBSTRING
)
6151 gfc_resolve_substring_charlen (e
);
6156 t
= resolve_typebound_function (e
);
6159 case EXPR_SUBSTRING
:
6160 t
= resolve_ref (e
);
6169 t
= resolve_expr_ppc (e
);
6174 if (!resolve_ref (e
))
6177 t
= gfc_resolve_array_constructor (e
);
6178 /* Also try to expand a constructor. */
6181 expression_rank (e
);
6182 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6183 gfc_expand_constructor (e
, false);
6186 /* This provides the opportunity for the length of constructors with
6187 character valued function elements to propagate the string length
6188 to the expression. */
6189 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6191 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6192 here rather then add a duplicate test for it above. */
6193 gfc_expand_constructor (e
, false);
6194 t
= gfc_resolve_character_array_constructor (e
);
6199 case EXPR_STRUCTURE
:
6200 t
= resolve_ref (e
);
6204 t
= resolve_structure_cons (e
, 0);
6208 t
= gfc_simplify_expr (e
, 0);
6212 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6215 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6218 inquiry_argument
= inquiry_save
;
6219 actual_arg
= actual_arg_save
;
6220 first_actual_arg
= first_actual_arg_save
;
6226 /* Resolve an expression from an iterator. They must be scalar and have
6227 INTEGER or (optionally) REAL type. */
6230 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6231 const char *name_msgid
)
6233 if (!gfc_resolve_expr (expr
))
6236 if (expr
->rank
!= 0)
6238 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6242 if (expr
->ts
.type
!= BT_INTEGER
)
6244 if (expr
->ts
.type
== BT_REAL
)
6247 return gfc_notify_std (GFC_STD_F95_DEL
,
6248 "%s at %L must be integer",
6249 _(name_msgid
), &expr
->where
);
6252 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6259 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6267 /* Resolve the expressions in an iterator structure. If REAL_OK is
6268 false allow only INTEGER type iterators, otherwise allow REAL types.
6269 Set own_scope to true for ac-implied-do and data-implied-do as those
6270 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6273 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6275 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6278 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6279 _("iterator variable")))
6282 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6283 "Start expression in DO loop"))
6286 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6287 "End expression in DO loop"))
6290 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6291 "Step expression in DO loop"))
6294 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6296 if ((iter
->step
->ts
.type
== BT_INTEGER
6297 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6298 || (iter
->step
->ts
.type
== BT_REAL
6299 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6301 gfc_error ("Step expression in DO loop at %L cannot be zero",
6302 &iter
->step
->where
);
6307 /* Convert start, end, and step to the same type as var. */
6308 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6309 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6310 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6312 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6313 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6314 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6316 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6317 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6318 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6320 if (iter
->start
->expr_type
== EXPR_CONSTANT
6321 && iter
->end
->expr_type
== EXPR_CONSTANT
6322 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6325 if (iter
->start
->ts
.type
== BT_INTEGER
)
6327 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6328 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6332 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6333 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6335 if (warn_zerotrip
&& ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6336 gfc_warning (OPT_Wzerotrip
,
6337 "DO loop at %L will be executed zero times",
6338 &iter
->step
->where
);
6345 /* Traversal function for find_forall_index. f == 2 signals that
6346 that variable itself is not to be checked - only the references. */
6349 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6351 if (expr
->expr_type
!= EXPR_VARIABLE
)
6354 /* A scalar assignment */
6355 if (!expr
->ref
|| *f
== 1)
6357 if (expr
->symtree
->n
.sym
== sym
)
6369 /* Check whether the FORALL index appears in the expression or not.
6370 Returns true if SYM is found in EXPR. */
6373 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6375 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6382 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6383 to be a scalar INTEGER variable. The subscripts and stride are scalar
6384 INTEGERs, and if stride is a constant it must be nonzero.
6385 Furthermore "A subscript or stride in a forall-triplet-spec shall
6386 not contain a reference to any index-name in the
6387 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6390 resolve_forall_iterators (gfc_forall_iterator
*it
)
6392 gfc_forall_iterator
*iter
, *iter2
;
6394 for (iter
= it
; iter
; iter
= iter
->next
)
6396 if (gfc_resolve_expr (iter
->var
)
6397 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6398 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6401 if (gfc_resolve_expr (iter
->start
)
6402 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6403 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6404 &iter
->start
->where
);
6405 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6406 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6408 if (gfc_resolve_expr (iter
->end
)
6409 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6410 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6412 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6413 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6415 if (gfc_resolve_expr (iter
->stride
))
6417 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6418 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6419 &iter
->stride
->where
, "INTEGER");
6421 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6422 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6423 gfc_error ("FORALL stride expression at %L cannot be zero",
6424 &iter
->stride
->where
);
6426 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6427 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6430 for (iter
= it
; iter
; iter
= iter
->next
)
6431 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6433 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6434 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6435 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6436 gfc_error ("FORALL index '%s' may not appear in triplet "
6437 "specification at %L", iter
->var
->symtree
->name
,
6438 &iter2
->start
->where
);
6443 /* Given a pointer to a symbol that is a derived type, see if it's
6444 inaccessible, i.e. if it's defined in another module and the components are
6445 PRIVATE. The search is recursive if necessary. Returns zero if no
6446 inaccessible components are found, nonzero otherwise. */
6449 derived_inaccessible (gfc_symbol
*sym
)
6453 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6456 for (c
= sym
->components
; c
; c
= c
->next
)
6458 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6466 /* Resolve the argument of a deallocate expression. The expression must be
6467 a pointer or a full array. */
6470 resolve_deallocate_expr (gfc_expr
*e
)
6472 symbol_attribute attr
;
6473 int allocatable
, pointer
;
6479 if (!gfc_resolve_expr (e
))
6482 if (e
->expr_type
!= EXPR_VARIABLE
)
6485 sym
= e
->symtree
->n
.sym
;
6486 unlimited
= UNLIMITED_POLY(sym
);
6488 if (sym
->ts
.type
== BT_CLASS
)
6490 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6491 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6495 allocatable
= sym
->attr
.allocatable
;
6496 pointer
= sym
->attr
.pointer
;
6498 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6503 if (ref
->u
.ar
.type
!= AR_FULL
6504 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6505 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6510 c
= ref
->u
.c
.component
;
6511 if (c
->ts
.type
== BT_CLASS
)
6513 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6514 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6518 allocatable
= c
->attr
.allocatable
;
6519 pointer
= c
->attr
.pointer
;
6529 attr
= gfc_expr_attr (e
);
6531 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6534 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6540 if (gfc_is_coindexed (e
))
6542 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6547 && !gfc_check_vardef_context (e
, true, true, false,
6548 _("DEALLOCATE object")))
6550 if (!gfc_check_vardef_context (e
, false, true, false,
6551 _("DEALLOCATE object")))
6558 /* Returns true if the expression e contains a reference to the symbol sym. */
6560 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6562 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6569 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6571 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6575 /* Given the expression node e for an allocatable/pointer of derived type to be
6576 allocated, get the expression node to be initialized afterwards (needed for
6577 derived types with default initializers, and derived types with allocatable
6578 components that need nullification.) */
6581 gfc_expr_to_initialize (gfc_expr
*e
)
6587 result
= gfc_copy_expr (e
);
6589 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6590 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6591 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6593 ref
->u
.ar
.type
= AR_FULL
;
6595 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6596 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6601 gfc_free_shape (&result
->shape
, result
->rank
);
6603 /* Recalculate rank, shape, etc. */
6604 gfc_resolve_expr (result
);
6609 /* If the last ref of an expression is an array ref, return a copy of the
6610 expression with that one removed. Otherwise, a copy of the original
6611 expression. This is used for allocate-expressions and pointer assignment
6612 LHS, where there may be an array specification that needs to be stripped
6613 off when using gfc_check_vardef_context. */
6616 remove_last_array_ref (gfc_expr
* e
)
6621 e2
= gfc_copy_expr (e
);
6622 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6623 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6625 gfc_free_ref_list (*r
);
6634 /* Used in resolve_allocate_expr to check that a allocation-object and
6635 a source-expr are conformable. This does not catch all possible
6636 cases; in particular a runtime checking is needed. */
6639 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6642 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6644 /* First compare rank. */
6645 if ((tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6646 || (!tail
&& e1
->rank
!= e2
->rank
))
6648 gfc_error ("Source-expr at %L must be scalar or have the "
6649 "same rank as the allocate-object at %L",
6650 &e1
->where
, &e2
->where
);
6661 for (i
= 0; i
< e1
->rank
; i
++)
6663 if (tail
->u
.ar
.start
[i
] == NULL
)
6666 if (tail
->u
.ar
.end
[i
])
6668 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6669 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6670 mpz_add_ui (s
, s
, 1);
6674 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6677 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6679 gfc_error_1 ("Source-expr at %L and allocate-object at %L must "
6680 "have the same shape", &e1
->where
, &e2
->where
);
6693 /* Resolve the expression in an ALLOCATE statement, doing the additional
6694 checks to see whether the expression is OK or not. The expression must
6695 have a trailing array reference that gives the size of the array. */
6698 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6700 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6704 symbol_attribute attr
;
6705 gfc_ref
*ref
, *ref2
;
6708 gfc_symbol
*sym
= NULL
;
6713 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6714 checking of coarrays. */
6715 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6716 if (ref
->next
== NULL
)
6719 if (ref
&& ref
->type
== REF_ARRAY
)
6720 ref
->u
.ar
.in_allocate
= true;
6722 if (!gfc_resolve_expr (e
))
6725 /* Make sure the expression is allocatable or a pointer. If it is
6726 pointer, the next-to-last reference must be a pointer. */
6730 sym
= e
->symtree
->n
.sym
;
6732 /* Check whether ultimate component is abstract and CLASS. */
6735 /* Is the allocate-object unlimited polymorphic? */
6736 unlimited
= UNLIMITED_POLY(e
);
6738 if (e
->expr_type
!= EXPR_VARIABLE
)
6741 attr
= gfc_expr_attr (e
);
6742 pointer
= attr
.pointer
;
6743 dimension
= attr
.dimension
;
6744 codimension
= attr
.codimension
;
6748 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6750 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6751 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6752 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6753 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6754 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6758 allocatable
= sym
->attr
.allocatable
;
6759 pointer
= sym
->attr
.pointer
;
6760 dimension
= sym
->attr
.dimension
;
6761 codimension
= sym
->attr
.codimension
;
6766 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6771 if (ref
->u
.ar
.codimen
> 0)
6774 for (n
= ref
->u
.ar
.dimen
;
6775 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6776 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6783 if (ref
->next
!= NULL
)
6791 gfc_error ("Coindexed allocatable object at %L",
6796 c
= ref
->u
.c
.component
;
6797 if (c
->ts
.type
== BT_CLASS
)
6799 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6800 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6801 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6802 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6803 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6807 allocatable
= c
->attr
.allocatable
;
6808 pointer
= c
->attr
.pointer
;
6809 dimension
= c
->attr
.dimension
;
6810 codimension
= c
->attr
.codimension
;
6811 is_abstract
= c
->attr
.abstract
;
6823 /* Check for F08:C628. */
6824 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6826 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6831 /* Some checks for the SOURCE tag. */
6834 /* Check F03:C631. */
6835 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6837 gfc_error_1 ("Type of entity at %L is type incompatible with "
6838 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6842 /* Check F03:C632 and restriction following Note 6.18. */
6843 if (code
->expr3
->rank
> 0 && !conformable_arrays (code
->expr3
, e
))
6846 /* Check F03:C633. */
6847 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6849 gfc_error_1 ("The allocate-object at %L and the source-expr at %L "
6850 "shall have the same kind type parameter",
6851 &e
->where
, &code
->expr3
->where
);
6855 /* Check F2008, C642. */
6856 if (code
->expr3
->ts
.type
== BT_DERIVED
6857 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6858 || (code
->expr3
->ts
.u
.derived
->from_intmod
6859 == INTMOD_ISO_FORTRAN_ENV
6860 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6861 == ISOFORTRAN_LOCK_TYPE
)))
6863 gfc_error_1 ("The source-expr at %L shall neither be of type "
6864 "LOCK_TYPE nor have a LOCK_TYPE component if "
6865 "allocate-object at %L is a coarray",
6866 &code
->expr3
->where
, &e
->where
);
6871 /* Check F08:C629. */
6872 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6875 gcc_assert (e
->ts
.type
== BT_CLASS
);
6876 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6877 "type-spec or source-expr", sym
->name
, &e
->where
);
6881 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6883 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6884 code
->ext
.alloc
.ts
.u
.cl
->length
);
6885 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6887 gfc_error ("Allocating %s at %L with type-spec requires the same "
6888 "character-length parameter as in the declaration",
6889 sym
->name
, &e
->where
);
6894 /* In the variable definition context checks, gfc_expr_attr is used
6895 on the expression. This is fooled by the array specification
6896 present in e, thus we have to eliminate that one temporarily. */
6897 e2
= remove_last_array_ref (e
);
6900 t
= gfc_check_vardef_context (e2
, true, true, false,
6901 _("ALLOCATE object"));
6903 t
= gfc_check_vardef_context (e2
, false, true, false,
6904 _("ALLOCATE object"));
6909 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6910 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6912 /* For class arrays, the initialization with SOURCE is done
6913 using _copy and trans_call. It is convenient to exploit that
6914 when the allocated type is different from the declared type but
6915 no SOURCE exists by setting expr3. */
6916 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6918 else if (!code
->expr3
)
6920 /* Set up default initializer if needed. */
6924 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6925 ts
= code
->ext
.alloc
.ts
;
6929 if (ts
.type
== BT_CLASS
)
6930 ts
= ts
.u
.derived
->components
->ts
;
6932 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6934 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6935 init_st
->loc
= code
->loc
;
6936 init_st
->expr1
= gfc_expr_to_initialize (e
);
6937 init_st
->expr2
= init_e
;
6938 init_st
->next
= code
->next
;
6939 code
->next
= init_st
;
6942 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6944 /* Default initialization via MOLD (non-polymorphic). */
6945 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6946 gfc_resolve_expr (rhs
);
6947 gfc_free_expr (code
->expr3
);
6951 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6953 /* Make sure the vtab symbol is present when
6954 the module variables are generated. */
6955 gfc_typespec ts
= e
->ts
;
6957 ts
= code
->expr3
->ts
;
6958 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6959 ts
= code
->ext
.alloc
.ts
;
6961 gfc_find_derived_vtab (ts
.u
.derived
);
6964 e
= gfc_expr_to_initialize (e
);
6966 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6968 /* Again, make sure the vtab symbol is present when
6969 the module variables are generated. */
6970 gfc_typespec
*ts
= NULL
;
6972 ts
= &code
->expr3
->ts
;
6974 ts
= &code
->ext
.alloc
.ts
;
6981 e
= gfc_expr_to_initialize (e
);
6984 if (dimension
== 0 && codimension
== 0)
6987 /* Make sure the last reference node is an array specification. */
6989 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6990 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6992 gfc_error ("Array specification required in ALLOCATE statement "
6993 "at %L", &e
->where
);
6997 /* Make sure that the array section reference makes sense in the
6998 context of an ALLOCATE specification. */
7003 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7004 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7006 gfc_error ("Coarray specification required in ALLOCATE statement "
7007 "at %L", &e
->where
);
7011 for (i
= 0; i
< ar
->dimen
; i
++)
7013 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7016 switch (ar
->dimen_type
[i
])
7022 if (ar
->start
[i
] != NULL
7023 && ar
->end
[i
] != NULL
7024 && ar
->stride
[i
] == NULL
)
7027 /* Fall Through... */
7032 case DIMEN_THIS_IMAGE
:
7033 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7039 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7041 sym
= a
->expr
->symtree
->n
.sym
;
7043 /* TODO - check derived type components. */
7044 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7047 if ((ar
->start
[i
] != NULL
7048 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7049 || (ar
->end
[i
] != NULL
7050 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7052 gfc_error ("'%s' must not appear in the array specification at "
7053 "%L in the same ALLOCATE statement where it is "
7054 "itself allocated", sym
->name
, &ar
->where
);
7060 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7062 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7063 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7065 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7067 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7068 "statement at %L", &e
->where
);
7074 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7075 && ar
->stride
[i
] == NULL
)
7078 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7091 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7093 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7094 gfc_alloc
*a
, *p
, *q
;
7097 errmsg
= code
->expr2
;
7099 /* Check the stat variable. */
7102 gfc_check_vardef_context (stat
, false, false, false,
7103 _("STAT variable"));
7105 if ((stat
->ts
.type
!= BT_INTEGER
7106 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7107 || stat
->ref
->type
== REF_COMPONENT
)))
7109 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7110 "variable", &stat
->where
);
7112 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7113 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7115 gfc_ref
*ref1
, *ref2
;
7118 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7119 ref1
= ref1
->next
, ref2
= ref2
->next
)
7121 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7123 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7132 gfc_error ("Stat-variable at %L shall not be %sd within "
7133 "the same %s statement", &stat
->where
, fcn
, fcn
);
7139 /* Check the errmsg variable. */
7143 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7146 gfc_check_vardef_context (errmsg
, false, false, false,
7147 _("ERRMSG variable"));
7149 if ((errmsg
->ts
.type
!= BT_CHARACTER
7151 && (errmsg
->ref
->type
== REF_ARRAY
7152 || errmsg
->ref
->type
== REF_COMPONENT
)))
7153 || errmsg
->rank
> 0 )
7154 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7155 "variable", &errmsg
->where
);
7157 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7158 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7160 gfc_ref
*ref1
, *ref2
;
7163 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7164 ref1
= ref1
->next
, ref2
= ref2
->next
)
7166 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7168 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7177 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7178 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7184 /* Check that an allocate-object appears only once in the statement. */
7186 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7189 for (q
= p
->next
; q
; q
= q
->next
)
7192 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7194 /* This is a potential collision. */
7195 gfc_ref
*pr
= pe
->ref
;
7196 gfc_ref
*qr
= qe
->ref
;
7198 /* Follow the references until
7199 a) They start to differ, in which case there is no error;
7200 you can deallocate a%b and a%c in a single statement
7201 b) Both of them stop, which is an error
7202 c) One of them stops, which is also an error. */
7205 if (pr
== NULL
&& qr
== NULL
)
7207 gfc_error_1 ("Allocate-object at %L also appears at %L",
7208 &pe
->where
, &qe
->where
);
7211 else if (pr
!= NULL
&& qr
== NULL
)
7213 gfc_error_1 ("Allocate-object at %L is subobject of"
7214 " object at %L", &pe
->where
, &qe
->where
);
7217 else if (pr
== NULL
&& qr
!= NULL
)
7219 gfc_error_1 ("Allocate-object at %L is subobject of"
7220 " object at %L", &qe
->where
, &pe
->where
);
7223 /* Here, pr != NULL && qr != NULL */
7224 gcc_assert(pr
->type
== qr
->type
);
7225 if (pr
->type
== REF_ARRAY
)
7227 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7229 gcc_assert (qr
->type
== REF_ARRAY
);
7231 if (pr
->next
&& qr
->next
)
7234 gfc_array_ref
*par
= &(pr
->u
.ar
);
7235 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7237 for (i
=0; i
<par
->dimen
; i
++)
7239 if ((par
->start
[i
] != NULL
7240 || qar
->start
[i
] != NULL
)
7241 && gfc_dep_compare_expr (par
->start
[i
],
7242 qar
->start
[i
]) != 0)
7249 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7262 if (strcmp (fcn
, "ALLOCATE") == 0)
7264 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7265 resolve_allocate_expr (a
->expr
, code
);
7269 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7270 resolve_deallocate_expr (a
->expr
);
7275 /************ SELECT CASE resolution subroutines ************/
7277 /* Callback function for our mergesort variant. Determines interval
7278 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7279 op1 > op2. Assumes we're not dealing with the default case.
7280 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7281 There are nine situations to check. */
7284 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7288 if (op1
->low
== NULL
) /* op1 = (:L) */
7290 /* op2 = (:N), so overlap. */
7292 /* op2 = (M:) or (M:N), L < M */
7293 if (op2
->low
!= NULL
7294 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7297 else if (op1
->high
== NULL
) /* op1 = (K:) */
7299 /* op2 = (M:), so overlap. */
7301 /* op2 = (:N) or (M:N), K > N */
7302 if (op2
->high
!= NULL
7303 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7306 else /* op1 = (K:L) */
7308 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7309 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7311 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7312 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7314 else /* op2 = (M:N) */
7318 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7321 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7330 /* Merge-sort a double linked case list, detecting overlap in the
7331 process. LIST is the head of the double linked case list before it
7332 is sorted. Returns the head of the sorted list if we don't see any
7333 overlap, or NULL otherwise. */
7336 check_case_overlap (gfc_case
*list
)
7338 gfc_case
*p
, *q
, *e
, *tail
;
7339 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7341 /* If the passed list was empty, return immediately. */
7348 /* Loop unconditionally. The only exit from this loop is a return
7349 statement, when we've finished sorting the case list. */
7356 /* Count the number of merges we do in this pass. */
7359 /* Loop while there exists a merge to be done. */
7364 /* Count this merge. */
7367 /* Cut the list in two pieces by stepping INSIZE places
7368 forward in the list, starting from P. */
7371 for (i
= 0; i
< insize
; i
++)
7380 /* Now we have two lists. Merge them! */
7381 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7383 /* See from which the next case to merge comes from. */
7386 /* P is empty so the next case must come from Q. */
7391 else if (qsize
== 0 || q
== NULL
)
7400 cmp
= compare_cases (p
, q
);
7403 /* The whole case range for P is less than the
7411 /* The whole case range for Q is greater than
7412 the case range for P. */
7419 /* The cases overlap, or they are the same
7420 element in the list. Either way, we must
7421 issue an error and get the next case from P. */
7422 /* FIXME: Sort P and Q by line number. */
7423 gfc_error_1 ("CASE label at %L overlaps with CASE "
7424 "label at %L", &p
->where
, &q
->where
);
7432 /* Add the next element to the merged list. */
7441 /* P has now stepped INSIZE places along, and so has Q. So
7442 they're the same. */
7447 /* If we have done only one merge or none at all, we've
7448 finished sorting the cases. */
7457 /* Otherwise repeat, merging lists twice the size. */
7463 /* Check to see if an expression is suitable for use in a CASE statement.
7464 Makes sure that all case expressions are scalar constants of the same
7465 type. Return false if anything is wrong. */
7468 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7470 if (e
== NULL
) return true;
7472 if (e
->ts
.type
!= case_expr
->ts
.type
)
7474 gfc_error ("Expression in CASE statement at %L must be of type %s",
7475 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7479 /* C805 (R808) For a given case-construct, each case-value shall be of
7480 the same type as case-expr. For character type, length differences
7481 are allowed, but the kind type parameters shall be the same. */
7483 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7485 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7486 &e
->where
, case_expr
->ts
.kind
);
7490 /* Convert the case value kind to that of case expression kind,
7493 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7494 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7498 gfc_error ("Expression in CASE statement at %L must be scalar",
7507 /* Given a completely parsed select statement, we:
7509 - Validate all expressions and code within the SELECT.
7510 - Make sure that the selection expression is not of the wrong type.
7511 - Make sure that no case ranges overlap.
7512 - Eliminate unreachable cases and unreachable code resulting from
7513 removing case labels.
7515 The standard does allow unreachable cases, e.g. CASE (5:3). But
7516 they are a hassle for code generation, and to prevent that, we just
7517 cut them out here. This is not necessary for overlapping cases
7518 because they are illegal and we never even try to generate code.
7520 We have the additional caveat that a SELECT construct could have
7521 been a computed GOTO in the source code. Fortunately we can fairly
7522 easily work around that here: The case_expr for a "real" SELECT CASE
7523 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7524 we have to do is make sure that the case_expr is a scalar integer
7528 resolve_select (gfc_code
*code
, bool select_type
)
7531 gfc_expr
*case_expr
;
7532 gfc_case
*cp
, *default_case
, *tail
, *head
;
7533 int seen_unreachable
;
7539 if (code
->expr1
== NULL
)
7541 /* This was actually a computed GOTO statement. */
7542 case_expr
= code
->expr2
;
7543 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7544 gfc_error ("Selection expression in computed GOTO statement "
7545 "at %L must be a scalar integer expression",
7548 /* Further checking is not necessary because this SELECT was built
7549 by the compiler, so it should always be OK. Just move the
7550 case_expr from expr2 to expr so that we can handle computed
7551 GOTOs as normal SELECTs from here on. */
7552 code
->expr1
= code
->expr2
;
7557 case_expr
= code
->expr1
;
7558 type
= case_expr
->ts
.type
;
7561 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7563 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7564 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7566 /* Punt. Going on here just produce more garbage error messages. */
7571 if (!select_type
&& case_expr
->rank
!= 0)
7573 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7574 "expression", &case_expr
->where
);
7580 /* Raise a warning if an INTEGER case value exceeds the range of
7581 the case-expr. Later, all expressions will be promoted to the
7582 largest kind of all case-labels. */
7584 if (type
== BT_INTEGER
)
7585 for (body
= code
->block
; body
; body
= body
->block
)
7586 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7589 && gfc_check_integer_range (cp
->low
->value
.integer
,
7590 case_expr
->ts
.kind
) != ARITH_OK
)
7591 gfc_warning ("Expression in CASE statement at %L is "
7592 "not in the range of %s", &cp
->low
->where
,
7593 gfc_typename (&case_expr
->ts
));
7596 && cp
->low
!= cp
->high
7597 && gfc_check_integer_range (cp
->high
->value
.integer
,
7598 case_expr
->ts
.kind
) != ARITH_OK
)
7599 gfc_warning ("Expression in CASE statement at %L is "
7600 "not in the range of %s", &cp
->high
->where
,
7601 gfc_typename (&case_expr
->ts
));
7604 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7605 of the SELECT CASE expression and its CASE values. Walk the lists
7606 of case values, and if we find a mismatch, promote case_expr to
7607 the appropriate kind. */
7609 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7611 for (body
= code
->block
; body
; body
= body
->block
)
7613 /* Walk the case label list. */
7614 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7616 /* Intercept the DEFAULT case. It does not have a kind. */
7617 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7620 /* Unreachable case ranges are discarded, so ignore. */
7621 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7622 && cp
->low
!= cp
->high
7623 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7627 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7628 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7630 if (cp
->high
!= NULL
7631 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7632 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7637 /* Assume there is no DEFAULT case. */
7638 default_case
= NULL
;
7643 for (body
= code
->block
; body
; body
= body
->block
)
7645 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7647 seen_unreachable
= 0;
7649 /* Walk the case label list, making sure that all case labels
7651 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7653 /* Count the number of cases in the whole construct. */
7656 /* Intercept the DEFAULT case. */
7657 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7659 if (default_case
!= NULL
)
7661 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
7662 "by a second DEFAULT CASE at %L",
7663 &default_case
->where
, &cp
->where
);
7674 /* Deal with single value cases and case ranges. Errors are
7675 issued from the validation function. */
7676 if (!validate_case_label_expr (cp
->low
, case_expr
)
7677 || !validate_case_label_expr (cp
->high
, case_expr
))
7683 if (type
== BT_LOGICAL
7684 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7685 || cp
->low
!= cp
->high
))
7687 gfc_error ("Logical range in CASE statement at %L is not "
7688 "allowed", &cp
->low
->where
);
7693 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7696 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7697 if (value
& seen_logical
)
7699 gfc_error ("Constant logical value in CASE statement "
7700 "is repeated at %L",
7705 seen_logical
|= value
;
7708 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7709 && cp
->low
!= cp
->high
7710 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7712 if (warn_surprising
)
7713 gfc_warning (OPT_Wsurprising
,
7714 "Range specification at %L can never be matched",
7717 cp
->unreachable
= 1;
7718 seen_unreachable
= 1;
7722 /* If the case range can be matched, it can also overlap with
7723 other cases. To make sure it does not, we put it in a
7724 double linked list here. We sort that with a merge sort
7725 later on to detect any overlapping cases. */
7729 head
->right
= head
->left
= NULL
;
7734 tail
->right
->left
= tail
;
7741 /* It there was a failure in the previous case label, give up
7742 for this case label list. Continue with the next block. */
7746 /* See if any case labels that are unreachable have been seen.
7747 If so, we eliminate them. This is a bit of a kludge because
7748 the case lists for a single case statement (label) is a
7749 single forward linked lists. */
7750 if (seen_unreachable
)
7752 /* Advance until the first case in the list is reachable. */
7753 while (body
->ext
.block
.case_list
!= NULL
7754 && body
->ext
.block
.case_list
->unreachable
)
7756 gfc_case
*n
= body
->ext
.block
.case_list
;
7757 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7759 gfc_free_case_list (n
);
7762 /* Strip all other unreachable cases. */
7763 if (body
->ext
.block
.case_list
)
7765 for (cp
= body
->ext
.block
.case_list
; cp
&& cp
->next
; cp
= cp
->next
)
7767 if (cp
->next
->unreachable
)
7769 gfc_case
*n
= cp
->next
;
7770 cp
->next
= cp
->next
->next
;
7772 gfc_free_case_list (n
);
7779 /* See if there were overlapping cases. If the check returns NULL,
7780 there was overlap. In that case we don't do anything. If head
7781 is non-NULL, we prepend the DEFAULT case. The sorted list can
7782 then used during code generation for SELECT CASE constructs with
7783 a case expression of a CHARACTER type. */
7786 head
= check_case_overlap (head
);
7788 /* Prepend the default_case if it is there. */
7789 if (head
!= NULL
&& default_case
)
7791 default_case
->left
= NULL
;
7792 default_case
->right
= head
;
7793 head
->left
= default_case
;
7797 /* Eliminate dead blocks that may be the result if we've seen
7798 unreachable case labels for a block. */
7799 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7801 if (body
->block
->ext
.block
.case_list
== NULL
)
7803 /* Cut the unreachable block from the code chain. */
7804 gfc_code
*c
= body
->block
;
7805 body
->block
= c
->block
;
7807 /* Kill the dead block, but not the blocks below it. */
7809 gfc_free_statements (c
);
7813 /* More than two cases is legal but insane for logical selects.
7814 Issue a warning for it. */
7815 if (warn_surprising
&& type
== BT_LOGICAL
&& ncases
> 2)
7816 gfc_warning (OPT_Wsurprising
,
7817 "Logical SELECT CASE block at %L has more that two cases",
7822 /* Check if a derived type is extensible. */
7825 gfc_type_is_extensible (gfc_symbol
*sym
)
7827 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7828 || (sym
->attr
.is_class
7829 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7833 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7834 correct as well as possibly the array-spec. */
7837 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7841 gcc_assert (sym
->assoc
);
7842 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7844 /* If this is for SELECT TYPE, the target may not yet be set. In that
7845 case, return. Resolution will be called later manually again when
7847 target
= sym
->assoc
->target
;
7850 gcc_assert (!sym
->assoc
->dangling
);
7852 if (resolve_target
&& !gfc_resolve_expr (target
))
7855 /* For variable targets, we get some attributes from the target. */
7856 if (target
->expr_type
== EXPR_VARIABLE
)
7860 gcc_assert (target
->symtree
);
7861 tsym
= target
->symtree
->n
.sym
;
7863 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7864 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7866 sym
->attr
.target
= tsym
->attr
.target
7867 || gfc_expr_attr (target
).pointer
;
7868 if (is_subref_array (target
))
7869 sym
->attr
.subref_array_pointer
= 1;
7872 /* Get type if this was not already set. Note that it can be
7873 some other type than the target in case this is a SELECT TYPE
7874 selector! So we must not update when the type is already there. */
7875 if (sym
->ts
.type
== BT_UNKNOWN
)
7876 sym
->ts
= target
->ts
;
7877 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7879 /* See if this is a valid association-to-variable. */
7880 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7881 && !gfc_has_vector_subscript (target
));
7883 /* Finally resolve if this is an array or not. */
7884 if (sym
->attr
.dimension
&& target
->rank
== 0)
7886 gfc_error ("Associate-name '%s' at %L is used as array",
7887 sym
->name
, &sym
->declared_at
);
7888 sym
->attr
.dimension
= 0;
7892 /* We cannot deal with class selectors that need temporaries. */
7893 if (target
->ts
.type
== BT_CLASS
7894 && gfc_ref_needs_temporary_p (target
->ref
))
7896 gfc_error ("CLASS selector at %L needs a temporary which is not "
7897 "yet implemented", &target
->where
);
7901 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7902 sym
->attr
.dimension
= 1;
7903 else if (target
->ts
.type
== BT_CLASS
)
7904 gfc_fix_class_refs (target
);
7906 /* The associate-name will have a correct type by now. Make absolutely
7907 sure that it has not picked up a dimension attribute. */
7908 if (sym
->ts
.type
== BT_CLASS
)
7909 sym
->attr
.dimension
= 0;
7911 if (sym
->attr
.dimension
)
7913 sym
->as
= gfc_get_array_spec ();
7914 sym
->as
->rank
= target
->rank
;
7915 sym
->as
->type
= AS_DEFERRED
;
7916 sym
->as
->corank
= gfc_get_corank (target
);
7919 /* Mark this as an associate variable. */
7920 sym
->attr
.associate_var
= 1;
7922 /* If the target is a good class object, so is the associate variable. */
7923 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7924 sym
->attr
.class_ok
= 1;
7928 /* Resolve a SELECT TYPE statement. */
7931 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7933 gfc_symbol
*selector_type
;
7934 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7935 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7938 char name
[GFC_MAX_SYMBOL_LEN
];
7943 ns
= code
->ext
.block
.ns
;
7946 /* Check for F03:C813. */
7947 if (code
->expr1
->ts
.type
!= BT_CLASS
7948 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7950 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7951 "at %L", &code
->loc
);
7955 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7960 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7961 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7962 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7964 /* F2008: C803 The selector expression must not be coindexed. */
7965 if (gfc_is_coindexed (code
->expr2
))
7967 gfc_error ("Selector at %L must not be coindexed",
7968 &code
->expr2
->where
);
7975 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7977 if (gfc_is_coindexed (code
->expr1
))
7979 gfc_error ("Selector at %L must not be coindexed",
7980 &code
->expr1
->where
);
7985 /* Loop over TYPE IS / CLASS IS cases. */
7986 for (body
= code
->block
; body
; body
= body
->block
)
7988 c
= body
->ext
.block
.case_list
;
7990 /* Check F03:C815. */
7991 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7992 && !selector_type
->attr
.unlimited_polymorphic
7993 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7995 gfc_error ("Derived type '%s' at %L must be extensible",
7996 c
->ts
.u
.derived
->name
, &c
->where
);
8001 /* Check F03:C816. */
8002 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8003 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8004 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8006 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8007 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8008 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8010 gfc_error ("Unexpected intrinsic type '%s' at %L",
8011 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8016 /* Check F03:C814. */
8017 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8019 gfc_error ("The type-spec at %L shall specify that each length "
8020 "type parameter is assumed", &c
->where
);
8025 /* Intercept the DEFAULT case. */
8026 if (c
->ts
.type
== BT_UNKNOWN
)
8028 /* Check F03:C818. */
8031 gfc_error_1 ("The DEFAULT CASE at %L cannot be followed "
8032 "by a second DEFAULT CASE at %L",
8033 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8038 default_case
= body
;
8045 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8046 target if present. If there are any EXIT statements referring to the
8047 SELECT TYPE construct, this is no problem because the gfc_code
8048 reference stays the same and EXIT is equally possible from the BLOCK
8049 it is changed to. */
8050 code
->op
= EXEC_BLOCK
;
8053 gfc_association_list
* assoc
;
8055 assoc
= gfc_get_association_list ();
8056 assoc
->st
= code
->expr1
->symtree
;
8057 assoc
->target
= gfc_copy_expr (code
->expr2
);
8058 assoc
->target
->where
= code
->expr2
->where
;
8059 /* assoc->variable will be set by resolve_assoc_var. */
8061 code
->ext
.block
.assoc
= assoc
;
8062 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8064 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8067 code
->ext
.block
.assoc
= NULL
;
8069 /* Add EXEC_SELECT to switch on type. */
8070 new_st
= gfc_get_code (code
->op
);
8071 new_st
->expr1
= code
->expr1
;
8072 new_st
->expr2
= code
->expr2
;
8073 new_st
->block
= code
->block
;
8074 code
->expr1
= code
->expr2
= NULL
;
8079 ns
->code
->next
= new_st
;
8081 code
->op
= EXEC_SELECT
;
8083 gfc_add_vptr_component (code
->expr1
);
8084 gfc_add_hash_component (code
->expr1
);
8086 /* Loop over TYPE IS / CLASS IS cases. */
8087 for (body
= code
->block
; body
; body
= body
->block
)
8089 c
= body
->ext
.block
.case_list
;
8091 if (c
->ts
.type
== BT_DERIVED
)
8092 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8093 c
->ts
.u
.derived
->hash_value
);
8094 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8099 ivtab
= gfc_find_vtab (&c
->ts
);
8100 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8101 e
= CLASS_DATA (ivtab
)->initializer
;
8102 c
->low
= c
->high
= gfc_copy_expr (e
);
8105 else if (c
->ts
.type
== BT_UNKNOWN
)
8108 /* Associate temporary to selector. This should only be done
8109 when this case is actually true, so build a new ASSOCIATE
8110 that does precisely this here (instead of using the
8113 if (c
->ts
.type
== BT_CLASS
)
8114 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8115 else if (c
->ts
.type
== BT_DERIVED
)
8116 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8117 else if (c
->ts
.type
== BT_CHARACTER
)
8119 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8120 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8121 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8122 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8123 charlen
, c
->ts
.kind
);
8126 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8129 st
= gfc_find_symtree (ns
->sym_root
, name
);
8130 gcc_assert (st
->n
.sym
->assoc
);
8131 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8132 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8133 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8134 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8136 new_st
= gfc_get_code (EXEC_BLOCK
);
8137 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8138 new_st
->ext
.block
.ns
->code
= body
->next
;
8139 body
->next
= new_st
;
8141 /* Chain in the new list only if it is marked as dangling. Otherwise
8142 there is a CASE label overlap and this is already used. Just ignore,
8143 the error is diagnosed elsewhere. */
8144 if (st
->n
.sym
->assoc
->dangling
)
8146 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8147 st
->n
.sym
->assoc
->dangling
= 0;
8150 resolve_assoc_var (st
->n
.sym
, false);
8153 /* Take out CLASS IS cases for separate treatment. */
8155 while (body
&& body
->block
)
8157 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8159 /* Add to class_is list. */
8160 if (class_is
== NULL
)
8162 class_is
= body
->block
;
8167 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8168 tail
->block
= body
->block
;
8171 /* Remove from EXEC_SELECT list. */
8172 body
->block
= body
->block
->block
;
8185 /* Add a default case to hold the CLASS IS cases. */
8186 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8187 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8189 tail
->ext
.block
.case_list
= gfc_get_case ();
8190 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8192 default_case
= tail
;
8195 /* More than one CLASS IS block? */
8196 if (class_is
->block
)
8200 /* Sort CLASS IS blocks by extension level. */
8204 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8207 /* F03:C817 (check for doubles). */
8208 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8209 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8211 gfc_error ("Double CLASS IS block in SELECT TYPE "
8213 &c2
->ext
.block
.case_list
->where
);
8216 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8217 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8220 (*c1
)->block
= c2
->block
;
8230 /* Generate IF chain. */
8231 if_st
= gfc_get_code (EXEC_IF
);
8233 for (body
= class_is
; body
; body
= body
->block
)
8235 new_st
->block
= gfc_get_code (EXEC_IF
);
8236 new_st
= new_st
->block
;
8237 /* Set up IF condition: Call _gfortran_is_extension_of. */
8238 new_st
->expr1
= gfc_get_expr ();
8239 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8240 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8241 new_st
->expr1
->ts
.kind
= 4;
8242 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8243 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8244 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8245 /* Set up arguments. */
8246 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8247 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8248 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8249 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8250 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8251 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8252 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8253 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8254 new_st
->next
= body
->next
;
8256 if (default_case
->next
)
8258 new_st
->block
= gfc_get_code (EXEC_IF
);
8259 new_st
= new_st
->block
;
8260 new_st
->next
= default_case
->next
;
8263 /* Replace CLASS DEFAULT code by the IF chain. */
8264 default_case
->next
= if_st
;
8267 /* Resolve the internal code. This can not be done earlier because
8268 it requires that the sym->assoc of selectors is set already. */
8269 gfc_current_ns
= ns
;
8270 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8271 gfc_current_ns
= old_ns
;
8273 resolve_select (code
, true);
8277 /* Resolve a transfer statement. This is making sure that:
8278 -- a derived type being transferred has only non-pointer components
8279 -- a derived type being transferred doesn't have private components, unless
8280 it's being transferred from the module where the type was defined
8281 -- we're not trying to transfer a whole assumed size array. */
8284 resolve_transfer (gfc_code
*code
)
8293 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8294 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8295 exp
= exp
->value
.op
.op1
;
8297 if (exp
&& exp
->expr_type
== EXPR_NULL
8300 gfc_error ("Invalid context for NULL () intrinsic at %L",
8305 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8306 && exp
->expr_type
!= EXPR_FUNCTION
))
8309 /* If we are reading, the variable will be changed. Note that
8310 code->ext.dt may be NULL if the TRANSFER is related to
8311 an INQUIRE statement -- but in this case, we are not reading, either. */
8312 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8313 && !gfc_check_vardef_context (exp
, false, false, false,
8317 sym
= exp
->symtree
->n
.sym
;
8320 /* Go to actual component transferred. */
8321 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8322 if (ref
->type
== REF_COMPONENT
)
8323 ts
= &ref
->u
.c
.component
->ts
;
8325 if (ts
->type
== BT_CLASS
)
8327 /* FIXME: Test for defined input/output. */
8328 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8329 "it is processed by a defined input/output procedure",
8334 if (ts
->type
== BT_DERIVED
)
8336 /* Check that transferred derived type doesn't contain POINTER
8338 if (ts
->u
.derived
->attr
.pointer_comp
)
8340 gfc_error ("Data transfer element at %L cannot have POINTER "
8341 "components unless it is processed by a defined "
8342 "input/output procedure", &code
->loc
);
8347 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8349 gfc_error ("Data transfer element at %L cannot have "
8350 "procedure pointer components", &code
->loc
);
8354 if (ts
->u
.derived
->attr
.alloc_comp
)
8356 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8357 "components unless it is processed by a defined "
8358 "input/output procedure", &code
->loc
);
8362 /* C_PTR and C_FUNPTR have private components which means they can not
8363 be printed. However, if -std=gnu and not -pedantic, allow
8364 the component to be printed to help debugging. */
8365 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8367 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8368 "cannot have PRIVATE components", &code
->loc
))
8371 else if (derived_inaccessible (ts
->u
.derived
))
8373 gfc_error ("Data transfer element at %L cannot have "
8374 "PRIVATE components",&code
->loc
);
8379 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8380 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8382 gfc_error ("Data transfer element at %L cannot be a full reference to "
8383 "an assumed-size array", &code
->loc
);
8389 /*********** Toplevel code resolution subroutines ***********/
8391 /* Find the set of labels that are reachable from this block. We also
8392 record the last statement in each block. */
8395 find_reachable_labels (gfc_code
*block
)
8402 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8404 /* Collect labels in this block. We don't keep those corresponding
8405 to END {IF|SELECT}, these are checked in resolve_branch by going
8406 up through the code_stack. */
8407 for (c
= block
; c
; c
= c
->next
)
8409 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8410 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8413 /* Merge with labels from parent block. */
8416 gcc_assert (cs_base
->prev
->reachable_labels
);
8417 bitmap_ior_into (cs_base
->reachable_labels
,
8418 cs_base
->prev
->reachable_labels
);
8424 resolve_lock_unlock (gfc_code
*code
)
8426 if (code
->expr1
->expr_type
== EXPR_FUNCTION
8427 && code
->expr1
->value
.function
.isym
8428 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
8429 remove_caf_get_intrinsic (code
->expr1
);
8431 if (code
->expr1
->ts
.type
!= BT_DERIVED
8432 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8433 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8434 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8435 || code
->expr1
->rank
!= 0
8436 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8437 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8438 &code
->expr1
->where
);
8442 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8443 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8444 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8445 &code
->expr2
->where
);
8448 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8449 _("STAT variable")))
8454 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8455 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8456 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8457 &code
->expr3
->where
);
8460 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8461 _("ERRMSG variable")))
8464 /* Check ACQUIRED_LOCK. */
8466 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8467 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8468 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8469 "variable", &code
->expr4
->where
);
8472 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8473 _("ACQUIRED_LOCK variable")))
8479 resolve_critical (gfc_code
*code
)
8481 gfc_symtree
*symtree
;
8482 gfc_symbol
*lock_type
;
8483 char name
[GFC_MAX_SYMBOL_LEN
];
8484 static int serial
= 0;
8486 if (gfc_option
.coarray
!= GFC_FCOARRAY_LIB
)
8489 symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8490 GFC_PREFIX ("lock_type"));
8492 lock_type
= symtree
->n
.sym
;
8495 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns
, &symtree
,
8498 lock_type
= symtree
->n
.sym
;
8499 lock_type
->attr
.flavor
= FL_DERIVED
;
8500 lock_type
->attr
.zero_comp
= 1;
8501 lock_type
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
8502 lock_type
->intmod_sym_id
= ISOFORTRAN_LOCK_TYPE
;
8505 sprintf(name
, GFC_PREFIX ("lock_var") "%d",serial
++);
8506 if (gfc_get_sym_tree (name
, gfc_current_ns
, &symtree
, false) != 0)
8509 code
->resolved_sym
= symtree
->n
.sym
;
8510 symtree
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
8511 symtree
->n
.sym
->attr
.referenced
= 1;
8512 symtree
->n
.sym
->attr
.artificial
= 1;
8513 symtree
->n
.sym
->attr
.codimension
= 1;
8514 symtree
->n
.sym
->ts
.type
= BT_DERIVED
;
8515 symtree
->n
.sym
->ts
.u
.derived
= lock_type
;
8516 symtree
->n
.sym
->as
= gfc_get_array_spec ();
8517 symtree
->n
.sym
->as
->corank
= 1;
8518 symtree
->n
.sym
->as
->type
= AS_EXPLICIT
;
8519 symtree
->n
.sym
->as
->cotype
= AS_EXPLICIT
;
8520 symtree
->n
.sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
,
8526 resolve_sync (gfc_code
*code
)
8528 /* Check imageset. The * case matches expr1 == NULL. */
8531 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8532 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8533 "INTEGER expression", &code
->expr1
->where
);
8534 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8535 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8536 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8537 &code
->expr1
->where
);
8538 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8539 && gfc_simplify_expr (code
->expr1
, 0))
8541 gfc_constructor
*cons
;
8542 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8543 for (; cons
; cons
= gfc_constructor_next (cons
))
8544 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8545 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8546 gfc_error ("Imageset argument at %L must between 1 and "
8547 "num_images()", &cons
->expr
->where
);
8553 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8554 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8555 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8556 &code
->expr2
->where
);
8560 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8561 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8562 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8563 &code
->expr3
->where
);
8567 /* Given a branch to a label, see if the branch is conforming.
8568 The code node describes where the branch is located. */
8571 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8578 /* Step one: is this a valid branching target? */
8580 if (label
->defined
== ST_LABEL_UNKNOWN
)
8582 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8587 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8589 gfc_error_1 ("Statement at %L is not a valid branch target statement "
8590 "for the branch statement at %L", &label
->where
, &code
->loc
);
8594 /* Step two: make sure this branch is not a branch to itself ;-) */
8596 if (code
->here
== label
)
8598 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8602 /* Step three: See if the label is in the same block as the
8603 branching statement. The hard work has been done by setting up
8604 the bitmap reachable_labels. */
8606 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8608 /* Check now whether there is a CRITICAL construct; if so, check
8609 whether the label is still visible outside of the CRITICAL block,
8610 which is invalid. */
8611 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8613 if (stack
->current
->op
== EXEC_CRITICAL
8614 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8615 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for "
8616 "label at %L", &code
->loc
, &label
->where
);
8617 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8618 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8619 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct "
8620 "for label at %L", &code
->loc
, &label
->where
);
8626 /* Step four: If we haven't found the label in the bitmap, it may
8627 still be the label of the END of the enclosing block, in which
8628 case we find it by going up the code_stack. */
8630 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8632 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8634 if (stack
->current
->op
== EXEC_CRITICAL
)
8636 /* Note: A label at END CRITICAL does not leave the CRITICAL
8637 construct as END CRITICAL is still part of it. */
8638 gfc_error_1 ("GOTO statement at %L leaves CRITICAL construct for label"
8639 " at %L", &code
->loc
, &label
->where
);
8642 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8644 gfc_error_1 ("GOTO statement at %L leaves DO CONCURRENT construct for "
8645 "label at %L", &code
->loc
, &label
->where
);
8652 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8656 /* The label is not in an enclosing block, so illegal. This was
8657 allowed in Fortran 66, so we allow it as extension. No
8658 further checks are necessary in this case. */
8659 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8660 "as the GOTO statement at %L", &label
->where
,
8666 /* Check whether EXPR1 has the same shape as EXPR2. */
8669 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8671 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8672 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8673 bool result
= false;
8676 /* Compare the rank. */
8677 if (expr1
->rank
!= expr2
->rank
)
8680 /* Compare the size of each dimension. */
8681 for (i
=0; i
<expr1
->rank
; i
++)
8683 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8686 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8689 if (mpz_cmp (shape
[i
], shape2
[i
]))
8693 /* When either of the two expression is an assumed size array, we
8694 ignore the comparison of dimension sizes. */
8699 gfc_clear_shape (shape
, i
);
8700 gfc_clear_shape (shape2
, i
);
8705 /* Check whether a WHERE assignment target or a WHERE mask expression
8706 has the same shape as the outmost WHERE mask expression. */
8709 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8715 cblock
= code
->block
;
8717 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8718 In case of nested WHERE, only the outmost one is stored. */
8719 if (mask
== NULL
) /* outmost WHERE */
8721 else /* inner WHERE */
8728 /* Check if the mask-expr has a consistent shape with the
8729 outmost WHERE mask-expr. */
8730 if (!resolve_where_shape (cblock
->expr1
, e
))
8731 gfc_error ("WHERE mask at %L has inconsistent shape",
8732 &cblock
->expr1
->where
);
8735 /* the assignment statement of a WHERE statement, or the first
8736 statement in where-body-construct of a WHERE construct */
8737 cnext
= cblock
->next
;
8742 /* WHERE assignment statement */
8745 /* Check shape consistent for WHERE assignment target. */
8746 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8747 gfc_error ("WHERE assignment target at %L has "
8748 "inconsistent shape", &cnext
->expr1
->where
);
8752 case EXEC_ASSIGN_CALL
:
8753 resolve_call (cnext
);
8754 if (!cnext
->resolved_sym
->attr
.elemental
)
8755 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8756 &cnext
->ext
.actual
->expr
->where
);
8759 /* WHERE or WHERE construct is part of a where-body-construct */
8761 resolve_where (cnext
, e
);
8765 gfc_error ("Unsupported statement inside WHERE at %L",
8768 /* the next statement within the same where-body-construct */
8769 cnext
= cnext
->next
;
8771 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8772 cblock
= cblock
->block
;
8777 /* Resolve assignment in FORALL construct.
8778 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8779 FORALL index variables. */
8782 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8786 for (n
= 0; n
< nvar
; n
++)
8788 gfc_symbol
*forall_index
;
8790 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8792 /* Check whether the assignment target is one of the FORALL index
8794 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8795 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8796 gfc_error ("Assignment to a FORALL index variable at %L",
8797 &code
->expr1
->where
);
8800 /* If one of the FORALL index variables doesn't appear in the
8801 assignment variable, then there could be a many-to-one
8802 assignment. Emit a warning rather than an error because the
8803 mask could be resolving this problem. */
8804 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8805 gfc_warning ("The FORALL with index %qs is not used on the "
8806 "left side of the assignment at %L and so might "
8807 "cause multiple assignment to this object",
8808 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8814 /* Resolve WHERE statement in FORALL construct. */
8817 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8818 gfc_expr
**var_expr
)
8823 cblock
= code
->block
;
8826 /* the assignment statement of a WHERE statement, or the first
8827 statement in where-body-construct of a WHERE construct */
8828 cnext
= cblock
->next
;
8833 /* WHERE assignment statement */
8835 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8838 /* WHERE operator assignment statement */
8839 case EXEC_ASSIGN_CALL
:
8840 resolve_call (cnext
);
8841 if (!cnext
->resolved_sym
->attr
.elemental
)
8842 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8843 &cnext
->ext
.actual
->expr
->where
);
8846 /* WHERE or WHERE construct is part of a where-body-construct */
8848 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8852 gfc_error ("Unsupported statement inside WHERE at %L",
8855 /* the next statement within the same where-body-construct */
8856 cnext
= cnext
->next
;
8858 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8859 cblock
= cblock
->block
;
8864 /* Traverse the FORALL body to check whether the following errors exist:
8865 1. For assignment, check if a many-to-one assignment happens.
8866 2. For WHERE statement, check the WHERE body to see if there is any
8867 many-to-one assignment. */
8870 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8874 c
= code
->block
->next
;
8880 case EXEC_POINTER_ASSIGN
:
8881 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8884 case EXEC_ASSIGN_CALL
:
8888 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8889 there is no need to handle it here. */
8893 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8898 /* The next statement in the FORALL body. */
8904 /* Counts the number of iterators needed inside a forall construct, including
8905 nested forall constructs. This is used to allocate the needed memory
8906 in gfc_resolve_forall. */
8909 gfc_count_forall_iterators (gfc_code
*code
)
8911 int max_iters
, sub_iters
, current_iters
;
8912 gfc_forall_iterator
*fa
;
8914 gcc_assert(code
->op
== EXEC_FORALL
);
8918 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8921 code
= code
->block
->next
;
8925 if (code
->op
== EXEC_FORALL
)
8927 sub_iters
= gfc_count_forall_iterators (code
);
8928 if (sub_iters
> max_iters
)
8929 max_iters
= sub_iters
;
8934 return current_iters
+ max_iters
;
8938 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8939 gfc_resolve_forall_body to resolve the FORALL body. */
8942 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8944 static gfc_expr
**var_expr
;
8945 static int total_var
= 0;
8946 static int nvar
= 0;
8948 gfc_forall_iterator
*fa
;
8953 /* Start to resolve a FORALL construct */
8954 if (forall_save
== 0)
8956 /* Count the total number of FORALL index in the nested FORALL
8957 construct in order to allocate the VAR_EXPR with proper size. */
8958 total_var
= gfc_count_forall_iterators (code
);
8960 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8961 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8964 /* The information about FORALL iterator, including FORALL index start, end
8965 and stride. The FORALL index can not appear in start, end or stride. */
8966 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8968 /* Check if any outer FORALL index name is the same as the current
8970 for (i
= 0; i
< nvar
; i
++)
8972 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8974 gfc_error ("An outer FORALL construct already has an index "
8975 "with this name %L", &fa
->var
->where
);
8979 /* Record the current FORALL index. */
8980 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8984 /* No memory leak. */
8985 gcc_assert (nvar
<= total_var
);
8988 /* Resolve the FORALL body. */
8989 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8991 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8992 gfc_resolve_blocks (code
->block
, ns
);
8996 /* Free only the VAR_EXPRs allocated in this frame. */
8997 for (i
= nvar
; i
< tmp
; i
++)
8998 gfc_free_expr (var_expr
[i
]);
9002 /* We are in the outermost FORALL construct. */
9003 gcc_assert (forall_save
== 0);
9005 /* VAR_EXPR is not needed any more. */
9012 /* Resolve a BLOCK construct statement. */
9015 resolve_block_construct (gfc_code
* code
)
9017 /* Resolve the BLOCK's namespace. */
9018 gfc_resolve (code
->ext
.block
.ns
);
9020 /* For an ASSOCIATE block, the associations (and their targets) are already
9021 resolved during resolve_symbol. */
9025 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9029 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9033 for (; b
; b
= b
->block
)
9035 t
= gfc_resolve_expr (b
->expr1
);
9036 if (!gfc_resolve_expr (b
->expr2
))
9042 if (t
&& b
->expr1
!= NULL
9043 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9044 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9051 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9052 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9057 resolve_branch (b
->label1
, b
);
9061 resolve_block_construct (b
);
9065 case EXEC_SELECT_TYPE
:
9069 case EXEC_DO_CONCURRENT
:
9077 case EXEC_OACC_PARALLEL_LOOP
:
9078 case EXEC_OACC_PARALLEL
:
9079 case EXEC_OACC_KERNELS_LOOP
:
9080 case EXEC_OACC_KERNELS
:
9081 case EXEC_OACC_DATA
:
9082 case EXEC_OACC_HOST_DATA
:
9083 case EXEC_OACC_LOOP
:
9084 case EXEC_OACC_UPDATE
:
9085 case EXEC_OACC_WAIT
:
9086 case EXEC_OACC_CACHE
:
9087 case EXEC_OACC_ENTER_DATA
:
9088 case EXEC_OACC_EXIT_DATA
:
9089 case EXEC_OMP_ATOMIC
:
9090 case EXEC_OMP_CRITICAL
:
9091 case EXEC_OMP_DISTRIBUTE
:
9092 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9093 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9094 case EXEC_OMP_DISTRIBUTE_SIMD
:
9096 case EXEC_OMP_DO_SIMD
:
9097 case EXEC_OMP_MASTER
:
9098 case EXEC_OMP_ORDERED
:
9099 case EXEC_OMP_PARALLEL
:
9100 case EXEC_OMP_PARALLEL_DO
:
9101 case EXEC_OMP_PARALLEL_DO_SIMD
:
9102 case EXEC_OMP_PARALLEL_SECTIONS
:
9103 case EXEC_OMP_PARALLEL_WORKSHARE
:
9104 case EXEC_OMP_SECTIONS
:
9106 case EXEC_OMP_SINGLE
:
9107 case EXEC_OMP_TARGET
:
9108 case EXEC_OMP_TARGET_DATA
:
9109 case EXEC_OMP_TARGET_TEAMS
:
9110 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9111 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9112 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9113 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9114 case EXEC_OMP_TARGET_UPDATE
:
9116 case EXEC_OMP_TASKGROUP
:
9117 case EXEC_OMP_TASKWAIT
:
9118 case EXEC_OMP_TASKYIELD
:
9119 case EXEC_OMP_TEAMS
:
9120 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9121 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9122 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9123 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9124 case EXEC_OMP_WORKSHARE
:
9128 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9131 gfc_resolve_code (b
->next
, ns
);
9136 /* Does everything to resolve an ordinary assignment. Returns true
9137 if this is an interface assignment. */
9139 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9148 symbol_attribute attr
;
9150 if (gfc_extend_assign (code
, ns
))
9154 if (code
->op
== EXEC_ASSIGN_CALL
)
9156 lhs
= code
->ext
.actual
->expr
;
9157 rhsptr
= &code
->ext
.actual
->next
->expr
;
9161 gfc_actual_arglist
* args
;
9162 gfc_typebound_proc
* tbp
;
9164 gcc_assert (code
->op
== EXEC_COMPCALL
);
9166 args
= code
->expr1
->value
.compcall
.actual
;
9168 rhsptr
= &args
->next
->expr
;
9170 tbp
= code
->expr1
->value
.compcall
.tbp
;
9171 gcc_assert (!tbp
->is_generic
);
9174 /* Make a temporary rhs when there is a default initializer
9175 and rhs is the same symbol as the lhs. */
9176 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9177 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9178 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9179 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9180 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9189 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9190 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9194 /* Handle the case of a BOZ literal on the RHS. */
9195 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9198 if (warn_surprising
)
9199 gfc_warning (OPT_Wsurprising
,
9200 "BOZ literal at %L is bitwise transferred "
9201 "non-integer symbol %qs", &code
->loc
,
9202 lhs
->symtree
->n
.sym
->name
);
9204 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9206 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9208 if (rc
== ARITH_UNDERFLOW
)
9209 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9210 ". This check can be disabled with the option "
9211 "-fno-range-check", &rhs
->where
);
9212 else if (rc
== ARITH_OVERFLOW
)
9213 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9214 ". This check can be disabled with the option "
9215 "-fno-range-check", &rhs
->where
);
9216 else if (rc
== ARITH_NAN
)
9217 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9218 ". This check can be disabled with the option "
9219 "-fno-range-check", &rhs
->where
);
9224 if (lhs
->ts
.type
== BT_CHARACTER
9225 && warn_character_truncation
)
9227 if (lhs
->ts
.u
.cl
!= NULL
9228 && lhs
->ts
.u
.cl
->length
!= NULL
9229 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9230 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9232 if (rhs
->expr_type
== EXPR_CONSTANT
)
9233 rlen
= rhs
->value
.character
.length
;
9235 else if (rhs
->ts
.u
.cl
!= NULL
9236 && rhs
->ts
.u
.cl
->length
!= NULL
9237 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9238 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9240 if (rlen
&& llen
&& rlen
> llen
)
9241 gfc_warning_now (OPT_Wcharacter_truncation
,
9242 "CHARACTER expression will be truncated "
9243 "in assignment (%d/%d) at %L",
9244 llen
, rlen
, &code
->loc
);
9247 /* Ensure that a vector index expression for the lvalue is evaluated
9248 to a temporary if the lvalue symbol is referenced in it. */
9251 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9252 if (ref
->type
== REF_ARRAY
)
9254 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9255 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9256 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9257 ref
->u
.ar
.start
[n
]))
9259 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9263 if (gfc_pure (NULL
))
9265 if (lhs
->ts
.type
== BT_DERIVED
9266 && lhs
->expr_type
== EXPR_VARIABLE
9267 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9268 && rhs
->expr_type
== EXPR_VARIABLE
9269 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9270 || gfc_is_coindexed (rhs
)))
9273 if (gfc_is_coindexed (rhs
))
9274 gfc_error ("Coindexed expression at %L is assigned to "
9275 "a derived type variable with a POINTER "
9276 "component in a PURE procedure",
9279 gfc_error ("The impure variable at %L is assigned to "
9280 "a derived type variable with a POINTER "
9281 "component in a PURE procedure (12.6)",
9286 /* Fortran 2008, C1283. */
9287 if (gfc_is_coindexed (lhs
))
9289 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9290 "procedure", &rhs
->where
);
9295 if (gfc_implicit_pure (NULL
))
9297 if (lhs
->expr_type
== EXPR_VARIABLE
9298 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9299 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9300 gfc_unset_implicit_pure (NULL
);
9302 if (lhs
->ts
.type
== BT_DERIVED
9303 && lhs
->expr_type
== EXPR_VARIABLE
9304 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9305 && rhs
->expr_type
== EXPR_VARIABLE
9306 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9307 || gfc_is_coindexed (rhs
)))
9308 gfc_unset_implicit_pure (NULL
);
9310 /* Fortran 2008, C1283. */
9311 if (gfc_is_coindexed (lhs
))
9312 gfc_unset_implicit_pure (NULL
);
9315 /* F2008, 7.2.1.2. */
9316 attr
= gfc_expr_attr (lhs
);
9317 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9319 if (attr
.codimension
)
9321 gfc_error ("Assignment to polymorphic coarray at %L is not "
9322 "permitted", &lhs
->where
);
9325 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9326 "polymorphic variable at %L", &lhs
->where
))
9328 if (!gfc_option
.flag_realloc_lhs
)
9330 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9331 "requires -frealloc-lhs", &lhs
->where
);
9335 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9336 "is not yet supported", &lhs
->where
);
9339 else if (lhs
->ts
.type
== BT_CLASS
)
9341 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9342 "assignment at %L - check that there is a matching specific "
9343 "subroutine for '=' operator", &lhs
->where
);
9347 bool lhs_coindexed
= gfc_is_coindexed (lhs
);
9349 /* F2008, Section 7.2.1.2. */
9350 if (lhs_coindexed
&& gfc_has_ultimate_allocatable (lhs
))
9352 gfc_error ("Coindexed variable must not have an allocatable ultimate "
9353 "component in assignment at %L", &lhs
->where
);
9357 gfc_check_assign (lhs
, rhs
, 1);
9359 /* Assign the 'data' of a class object to a derived type. */
9360 if (lhs
->ts
.type
== BT_DERIVED
9361 && rhs
->ts
.type
== BT_CLASS
)
9362 gfc_add_data_component (rhs
);
9364 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
9365 Additionally, insert this code when the RHS is a CAF as we then use the
9366 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
9367 the LHS is (re)allocatable or has a vector subscript. If the LHS is a
9368 noncoindexed array and the RHS is a coindexed scalar, use the normal code
9370 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
9372 || (code
->expr2
->expr_type
== EXPR_FUNCTION
9373 && code
->expr2
->value
.function
.isym
9374 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
9375 && (code
->expr1
->rank
== 0 || code
->expr2
->rank
!= 0)
9376 && !gfc_expr_attr (rhs
).allocatable
9377 && !gfc_has_vector_subscript (rhs
))))
9379 if (code
->expr2
->expr_type
== EXPR_FUNCTION
9380 && code
->expr2
->value
.function
.isym
9381 && code
->expr2
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
9382 remove_caf_get_intrinsic (code
->expr2
);
9383 code
->op
= EXEC_CALL
;
9384 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns
, &code
->symtree
, true);
9385 code
->resolved_sym
= code
->symtree
->n
.sym
;
9386 code
->resolved_sym
->attr
.flavor
= FL_PROCEDURE
;
9387 code
->resolved_sym
->attr
.intrinsic
= 1;
9388 code
->resolved_sym
->attr
.subroutine
= 1;
9389 code
->resolved_isym
= gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND
);
9390 gfc_commit_symbol (code
->resolved_sym
);
9391 code
->ext
.actual
= gfc_get_actual_arglist ();
9392 code
->ext
.actual
->expr
= lhs
;
9393 code
->ext
.actual
->next
= gfc_get_actual_arglist ();
9394 code
->ext
.actual
->next
->expr
= rhs
;
9403 /* Add a component reference onto an expression. */
9406 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9411 ref
= &((*ref
)->next
);
9412 *ref
= gfc_get_ref ();
9413 (*ref
)->type
= REF_COMPONENT
;
9414 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9415 (*ref
)->u
.c
.component
= c
;
9418 /* Add a full array ref, as necessary. */
9421 gfc_add_full_array_ref (e
, c
->as
);
9422 e
->rank
= c
->as
->rank
;
9427 /* Build an assignment. Keep the argument 'op' for future use, so that
9428 pointer assignments can be made. */
9431 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9432 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9434 gfc_code
*this_code
;
9436 this_code
= gfc_get_code (op
);
9437 this_code
->next
= NULL
;
9438 this_code
->expr1
= gfc_copy_expr (expr1
);
9439 this_code
->expr2
= gfc_copy_expr (expr2
);
9440 this_code
->loc
= loc
;
9443 add_comp_ref (this_code
->expr1
, comp1
);
9444 add_comp_ref (this_code
->expr2
, comp2
);
9451 /* Makes a temporary variable expression based on the characteristics of
9452 a given variable expression. */
9455 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9457 static int serial
= 0;
9458 char name
[GFC_MAX_SYMBOL_LEN
];
9461 gfc_array_ref
*aref
;
9464 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9465 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9466 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9472 /* This function could be expanded to support other expression type
9473 but this is not needed here. */
9474 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9476 /* Obtain the arrayspec for the temporary. */
9479 aref
= gfc_find_array_ref (e
);
9480 if (e
->expr_type
== EXPR_VARIABLE
9481 && e
->symtree
->n
.sym
->as
== aref
->as
)
9485 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9486 if (ref
->type
== REF_COMPONENT
9487 && ref
->u
.c
.component
->as
== aref
->as
)
9495 /* Add the attributes and the arrayspec to the temporary. */
9496 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9497 tmp
->n
.sym
->attr
.function
= 0;
9498 tmp
->n
.sym
->attr
.result
= 0;
9499 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9503 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9506 if (as
->type
== AS_DEFERRED
)
9507 tmp
->n
.sym
->attr
.allocatable
= 1;
9510 tmp
->n
.sym
->attr
.dimension
= 0;
9512 gfc_set_sym_referenced (tmp
->n
.sym
);
9513 gfc_commit_symbol (tmp
->n
.sym
);
9514 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9516 /* Should the lhs be a section, use its array ref for the
9517 temporary expression. */
9518 if (aref
&& aref
->type
!= AR_FULL
)
9520 gfc_free_ref_list (e
->ref
);
9521 e
->ref
= gfc_copy_ref (ref
);
9527 /* Add one line of code to the code chain, making sure that 'head' and
9528 'tail' are appropriately updated. */
9531 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9533 gcc_assert (this_code
);
9535 *head
= *tail
= *this_code
;
9537 *tail
= gfc_append_code (*tail
, *this_code
);
9542 /* Counts the potential number of part array references that would
9543 result from resolution of typebound defined assignments. */
9546 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9549 int c_depth
= 0, t_depth
;
9551 for (c
= derived
->components
; c
; c
= c
->next
)
9553 if ((c
->ts
.type
!= BT_DERIVED
9555 || c
->attr
.allocatable
9556 || c
->attr
.proc_pointer_comp
9557 || c
->attr
.class_pointer
9558 || c
->attr
.proc_pointer
)
9559 && !c
->attr
.defined_assign_comp
)
9562 if (c
->as
&& c_depth
== 0)
9565 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9566 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9571 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9573 return depth
+ c_depth
;
9577 /* Implement 7.2.1.3 of the F08 standard:
9578 "An intrinsic assignment where the variable is of derived type is
9579 performed as if each component of the variable were assigned from the
9580 corresponding component of expr using pointer assignment (7.2.2) for
9581 each pointer component, defined assignment for each nonpointer
9582 nonallocatable component of a type that has a type-bound defined
9583 assignment consistent with the component, intrinsic assignment for
9584 each other nonpointer nonallocatable component, ..."
9586 The pointer assignments are taken care of by the intrinsic
9587 assignment of the structure itself. This function recursively adds
9588 defined assignments where required. The recursion is accomplished
9589 by calling gfc_resolve_code.
9591 When the lhs in a defined assignment has intent INOUT, we need a
9592 temporary for the lhs. In pseudo-code:
9594 ! Only call function lhs once.
9595 if (lhs is not a constant or an variable)
9598 ! Do the intrinsic assignment
9600 ! Now do the defined assignments
9601 do over components with typebound defined assignment [%cmp]
9602 #if one component's assignment procedure is INOUT
9604 #if expr2 non-variable
9610 t1%cmp {defined=} expr2%cmp
9616 expr1%cmp {defined=} expr2%cmp
9620 /* The temporary assignments have to be put on top of the additional
9621 code to avoid the result being changed by the intrinsic assignment.
9623 static int component_assignment_level
= 0;
9624 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9627 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9629 gfc_component
*comp1
, *comp2
;
9630 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9632 int error_count
, depth
;
9634 gfc_get_errors (NULL
, &error_count
);
9636 /* Filter out continuing processing after an error. */
9638 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9639 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9642 /* TODO: Handle more than one part array reference in assignments. */
9643 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9644 (*code
)->expr1
->rank
? 1 : 0);
9647 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9648 "done because multiple part array references would "
9649 "occur in intermediate expressions.", &(*code
)->loc
);
9653 component_assignment_level
++;
9655 /* Create a temporary so that functions get called only once. */
9656 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9657 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9661 /* Assign the rhs to the temporary. */
9662 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9663 this_code
= build_assignment (EXEC_ASSIGN
,
9664 tmp_expr
, (*code
)->expr2
,
9665 NULL
, NULL
, (*code
)->loc
);
9666 /* Add the code and substitute the rhs expression. */
9667 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9668 gfc_free_expr ((*code
)->expr2
);
9669 (*code
)->expr2
= tmp_expr
;
9672 /* Do the intrinsic assignment. This is not needed if the lhs is one
9673 of the temporaries generated here, since the intrinsic assignment
9674 to the final result already does this. */
9675 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9677 this_code
= build_assignment (EXEC_ASSIGN
,
9678 (*code
)->expr1
, (*code
)->expr2
,
9679 NULL
, NULL
, (*code
)->loc
);
9680 add_code_to_chain (&this_code
, &head
, &tail
);
9683 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9684 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9687 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9691 /* The intrinsic assignment does the right thing for pointers
9692 of all kinds and allocatable components. */
9693 if (comp1
->ts
.type
!= BT_DERIVED
9694 || comp1
->attr
.pointer
9695 || comp1
->attr
.allocatable
9696 || comp1
->attr
.proc_pointer_comp
9697 || comp1
->attr
.class_pointer
9698 || comp1
->attr
.proc_pointer
)
9701 /* Make an assigment for this component. */
9702 this_code
= build_assignment (EXEC_ASSIGN
,
9703 (*code
)->expr1
, (*code
)->expr2
,
9704 comp1
, comp2
, (*code
)->loc
);
9706 /* Convert the assignment if there is a defined assignment for
9707 this type. Otherwise, using the call from gfc_resolve_code,
9708 recurse into its components. */
9709 gfc_resolve_code (this_code
, ns
);
9711 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9713 gfc_formal_arglist
*dummy_args
;
9715 /* Check that there is a typebound defined assignment. If not,
9716 then this must be a module defined assignment. We cannot
9717 use the defined_assign_comp attribute here because it must
9718 be this derived type that has the defined assignment and not
9720 if (!(comp1
->ts
.u
.derived
->f2k_derived
9721 && comp1
->ts
.u
.derived
->f2k_derived
9722 ->tb_op
[INTRINSIC_ASSIGN
]))
9724 gfc_free_statements (this_code
);
9729 /* If the first argument of the subroutine has intent INOUT
9730 a temporary must be generated and used instead. */
9731 rsym
= this_code
->resolved_sym
;
9732 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9734 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9736 gfc_code
*temp_code
;
9739 /* Build the temporary required for the assignment and put
9740 it at the head of the generated code. */
9743 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9744 temp_code
= build_assignment (EXEC_ASSIGN
,
9746 NULL
, NULL
, (*code
)->loc
);
9748 /* For allocatable LHS, check whether it is allocated. Note
9749 that allocatable components with defined assignment are
9750 not yet support. See PR 57696. */
9751 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9755 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9756 block
= gfc_get_code (EXEC_IF
);
9757 block
->block
= gfc_get_code (EXEC_IF
);
9759 = gfc_build_intrinsic_call (ns
,
9760 GFC_ISYM_ALLOCATED
, "allocated",
9761 (*code
)->loc
, 1, e
);
9762 block
->block
->next
= temp_code
;
9765 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9768 /* Replace the first actual arg with the component of the
9770 gfc_free_expr (this_code
->ext
.actual
->expr
);
9771 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9772 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9774 /* If the LHS variable is allocatable and wasn't allocated and
9775 the temporary is allocatable, pointer assign the address of
9776 the freshly allocated LHS to the temporary. */
9777 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9778 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9783 cond
= gfc_get_expr ();
9784 cond
->ts
.type
= BT_LOGICAL
;
9785 cond
->ts
.kind
= gfc_default_logical_kind
;
9786 cond
->expr_type
= EXPR_OP
;
9787 cond
->where
= (*code
)->loc
;
9788 cond
->value
.op
.op
= INTRINSIC_NOT
;
9789 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9790 GFC_ISYM_ALLOCATED
, "allocated",
9791 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9792 block
= gfc_get_code (EXEC_IF
);
9793 block
->block
= gfc_get_code (EXEC_IF
);
9794 block
->block
->expr1
= cond
;
9795 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9797 NULL
, NULL
, (*code
)->loc
);
9798 add_code_to_chain (&block
, &head
, &tail
);
9802 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9804 /* Don't add intrinsic assignments since they are already
9805 effected by the intrinsic assignment of the structure. */
9806 gfc_free_statements (this_code
);
9811 add_code_to_chain (&this_code
, &head
, &tail
);
9815 /* Transfer the value to the final result. */
9816 this_code
= build_assignment (EXEC_ASSIGN
,
9818 comp1
, comp2
, (*code
)->loc
);
9819 add_code_to_chain (&this_code
, &head
, &tail
);
9823 /* Put the temporary assignments at the top of the generated code. */
9824 if (tmp_head
&& component_assignment_level
== 1)
9826 gfc_append_code (tmp_head
, head
);
9828 tmp_head
= tmp_tail
= NULL
;
9831 // If we did a pointer assignment - thus, we need to ensure that the LHS is
9832 // not accidentally deallocated. Hence, nullify t1.
9833 if (t1
&& (*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9834 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9840 e
= gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9841 cond
= gfc_build_intrinsic_call (ns
, GFC_ISYM_ASSOCIATED
, "associated",
9842 (*code
)->loc
, 2, gfc_copy_expr (t1
), e
);
9843 block
= gfc_get_code (EXEC_IF
);
9844 block
->block
= gfc_get_code (EXEC_IF
);
9845 block
->block
->expr1
= cond
;
9846 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9847 t1
, gfc_get_null_expr (&(*code
)->loc
),
9848 NULL
, NULL
, (*code
)->loc
);
9849 gfc_append_code (tail
, block
);
9853 /* Now attach the remaining code chain to the input code. Step on
9854 to the end of the new code since resolution is complete. */
9855 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9856 tail
->next
= (*code
)->next
;
9857 /* Overwrite 'code' because this would place the intrinsic assignment
9858 before the temporary for the lhs is created. */
9859 gfc_free_expr ((*code
)->expr1
);
9860 gfc_free_expr ((*code
)->expr2
);
9866 component_assignment_level
--;
9870 /* Given a block of code, recursively resolve everything pointed to by this
9874 gfc_resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9876 int omp_workshare_save
;
9877 int forall_save
, do_concurrent_save
;
9881 frame
.prev
= cs_base
;
9885 find_reachable_labels (code
);
9887 for (; code
; code
= code
->next
)
9889 frame
.current
= code
;
9890 forall_save
= forall_flag
;
9891 do_concurrent_save
= gfc_do_concurrent_flag
;
9893 if (code
->op
== EXEC_FORALL
)
9896 gfc_resolve_forall (code
, ns
, forall_save
);
9899 else if (code
->block
)
9901 omp_workshare_save
= -1;
9904 case EXEC_OACC_PARALLEL_LOOP
:
9905 case EXEC_OACC_PARALLEL
:
9906 case EXEC_OACC_KERNELS_LOOP
:
9907 case EXEC_OACC_KERNELS
:
9908 case EXEC_OACC_DATA
:
9909 case EXEC_OACC_HOST_DATA
:
9910 case EXEC_OACC_LOOP
:
9911 gfc_resolve_oacc_blocks (code
, ns
);
9913 case EXEC_OMP_PARALLEL_WORKSHARE
:
9914 omp_workshare_save
= omp_workshare_flag
;
9915 omp_workshare_flag
= 1;
9916 gfc_resolve_omp_parallel_blocks (code
, ns
);
9918 case EXEC_OMP_PARALLEL
:
9919 case EXEC_OMP_PARALLEL_DO
:
9920 case EXEC_OMP_PARALLEL_DO_SIMD
:
9921 case EXEC_OMP_PARALLEL_SECTIONS
:
9922 case EXEC_OMP_TARGET_TEAMS
:
9923 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9924 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9925 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9926 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9928 case EXEC_OMP_TEAMS
:
9929 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9930 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9931 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9932 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9933 omp_workshare_save
= omp_workshare_flag
;
9934 omp_workshare_flag
= 0;
9935 gfc_resolve_omp_parallel_blocks (code
, ns
);
9937 case EXEC_OMP_DISTRIBUTE
:
9938 case EXEC_OMP_DISTRIBUTE_SIMD
:
9940 case EXEC_OMP_DO_SIMD
:
9942 gfc_resolve_omp_do_blocks (code
, ns
);
9944 case EXEC_SELECT_TYPE
:
9945 /* Blocks are handled in resolve_select_type because we have
9946 to transform the SELECT TYPE into ASSOCIATE first. */
9948 case EXEC_DO_CONCURRENT
:
9949 gfc_do_concurrent_flag
= 1;
9950 gfc_resolve_blocks (code
->block
, ns
);
9951 gfc_do_concurrent_flag
= 2;
9953 case EXEC_OMP_WORKSHARE
:
9954 omp_workshare_save
= omp_workshare_flag
;
9955 omp_workshare_flag
= 1;
9958 gfc_resolve_blocks (code
->block
, ns
);
9962 if (omp_workshare_save
!= -1)
9963 omp_workshare_flag
= omp_workshare_save
;
9967 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9968 t
= gfc_resolve_expr (code
->expr1
);
9969 forall_flag
= forall_save
;
9970 gfc_do_concurrent_flag
= do_concurrent_save
;
9972 if (!gfc_resolve_expr (code
->expr2
))
9975 if (code
->op
== EXEC_ALLOCATE
9976 && !gfc_resolve_expr (code
->expr3
))
9982 case EXEC_END_BLOCK
:
9983 case EXEC_END_NESTED_BLOCK
:
9987 case EXEC_ERROR_STOP
:
9991 case EXEC_ASSIGN_CALL
:
9995 resolve_critical (code
);
9999 case EXEC_SYNC_IMAGES
:
10000 case EXEC_SYNC_MEMORY
:
10001 resolve_sync (code
);
10006 resolve_lock_unlock (code
);
10010 /* Keep track of which entry we are up to. */
10011 current_entry_id
= code
->ext
.entry
->id
;
10015 resolve_where (code
, NULL
);
10019 if (code
->expr1
!= NULL
)
10021 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10022 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10023 "INTEGER variable", &code
->expr1
->where
);
10024 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10025 gfc_error ("Variable %qs has not been assigned a target "
10026 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10027 &code
->expr1
->where
);
10030 resolve_branch (code
->label1
, code
);
10034 if (code
->expr1
!= NULL
10035 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10036 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10037 "INTEGER return specifier", &code
->expr1
->where
);
10040 case EXEC_INIT_ASSIGN
:
10041 case EXEC_END_PROCEDURE
:
10048 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
10050 if (code
->expr1
->expr_type
== EXPR_FUNCTION
10051 && code
->expr1
->value
.function
.isym
10052 && code
->expr1
->value
.function
.isym
->id
== GFC_ISYM_CAF_GET
)
10053 remove_caf_get_intrinsic (code
->expr1
);
10055 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
10059 if (resolve_ordinary_assign (code
, ns
))
10061 if (code
->op
== EXEC_COMPCALL
)
10067 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10068 if (code
->op
!= EXEC_CALL
&& code
->expr1
->ts
.type
== BT_DERIVED
10069 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10070 generate_component_assignments (&code
, ns
);
10074 case EXEC_LABEL_ASSIGN
:
10075 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10076 gfc_error ("Label %d referenced at %L is never defined",
10077 code
->label1
->value
, &code
->label1
->where
);
10079 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10080 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10081 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10082 != gfc_default_integer_kind
10083 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10084 gfc_error ("ASSIGN statement at %L requires a scalar "
10085 "default INTEGER variable", &code
->expr1
->where
);
10088 case EXEC_POINTER_ASSIGN
:
10095 /* This is both a variable definition and pointer assignment
10096 context, so check both of them. For rank remapping, a final
10097 array ref may be present on the LHS and fool gfc_expr_attr
10098 used in gfc_check_vardef_context. Remove it. */
10099 e
= remove_last_array_ref (code
->expr1
);
10100 t
= gfc_check_vardef_context (e
, true, false, false,
10101 _("pointer assignment"));
10103 t
= gfc_check_vardef_context (e
, false, false, false,
10104 _("pointer assignment"));
10109 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10113 case EXEC_ARITHMETIC_IF
:
10115 && code
->expr1
->ts
.type
!= BT_INTEGER
10116 && code
->expr1
->ts
.type
!= BT_REAL
)
10117 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10118 "expression", &code
->expr1
->where
);
10120 resolve_branch (code
->label1
, code
);
10121 resolve_branch (code
->label2
, code
);
10122 resolve_branch (code
->label3
, code
);
10126 if (t
&& code
->expr1
!= NULL
10127 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10128 || code
->expr1
->rank
!= 0))
10129 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10130 &code
->expr1
->where
);
10135 resolve_call (code
);
10138 case EXEC_COMPCALL
:
10140 resolve_typebound_subroutine (code
);
10143 case EXEC_CALL_PPC
:
10144 resolve_ppc_call (code
);
10148 /* Select is complicated. Also, a SELECT construct could be
10149 a transformed computed GOTO. */
10150 resolve_select (code
, false);
10153 case EXEC_SELECT_TYPE
:
10154 resolve_select_type (code
, ns
);
10158 resolve_block_construct (code
);
10162 if (code
->ext
.iterator
!= NULL
)
10164 gfc_iterator
*iter
= code
->ext
.iterator
;
10165 if (gfc_resolve_iterator (iter
, true, false))
10166 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10170 case EXEC_DO_WHILE
:
10171 if (code
->expr1
== NULL
)
10172 gfc_internal_error ("gfc_resolve_code(): No expression on "
10175 && (code
->expr1
->rank
!= 0
10176 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10177 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10178 "a scalar LOGICAL expression", &code
->expr1
->where
);
10181 case EXEC_ALLOCATE
:
10183 resolve_allocate_deallocate (code
, "ALLOCATE");
10187 case EXEC_DEALLOCATE
:
10189 resolve_allocate_deallocate (code
, "DEALLOCATE");
10194 if (!gfc_resolve_open (code
->ext
.open
))
10197 resolve_branch (code
->ext
.open
->err
, code
);
10201 if (!gfc_resolve_close (code
->ext
.close
))
10204 resolve_branch (code
->ext
.close
->err
, code
);
10207 case EXEC_BACKSPACE
:
10211 if (!gfc_resolve_filepos (code
->ext
.filepos
))
10214 resolve_branch (code
->ext
.filepos
->err
, code
);
10218 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10221 resolve_branch (code
->ext
.inquire
->err
, code
);
10224 case EXEC_IOLENGTH
:
10225 gcc_assert (code
->ext
.inquire
!= NULL
);
10226 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10229 resolve_branch (code
->ext
.inquire
->err
, code
);
10233 if (!gfc_resolve_wait (code
->ext
.wait
))
10236 resolve_branch (code
->ext
.wait
->err
, code
);
10237 resolve_branch (code
->ext
.wait
->end
, code
);
10238 resolve_branch (code
->ext
.wait
->eor
, code
);
10243 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10246 resolve_branch (code
->ext
.dt
->err
, code
);
10247 resolve_branch (code
->ext
.dt
->end
, code
);
10248 resolve_branch (code
->ext
.dt
->eor
, code
);
10251 case EXEC_TRANSFER
:
10252 resolve_transfer (code
);
10255 case EXEC_DO_CONCURRENT
:
10257 resolve_forall_iterators (code
->ext
.forall_iterator
);
10259 if (code
->expr1
!= NULL
10260 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10261 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10262 "expression", &code
->expr1
->where
);
10265 case EXEC_OACC_PARALLEL_LOOP
:
10266 case EXEC_OACC_PARALLEL
:
10267 case EXEC_OACC_KERNELS_LOOP
:
10268 case EXEC_OACC_KERNELS
:
10269 case EXEC_OACC_DATA
:
10270 case EXEC_OACC_HOST_DATA
:
10271 case EXEC_OACC_LOOP
:
10272 case EXEC_OACC_UPDATE
:
10273 case EXEC_OACC_WAIT
:
10274 case EXEC_OACC_CACHE
:
10275 case EXEC_OACC_ENTER_DATA
:
10276 case EXEC_OACC_EXIT_DATA
:
10277 gfc_resolve_oacc_directive (code
, ns
);
10280 case EXEC_OMP_ATOMIC
:
10281 case EXEC_OMP_BARRIER
:
10282 case EXEC_OMP_CANCEL
:
10283 case EXEC_OMP_CANCELLATION_POINT
:
10284 case EXEC_OMP_CRITICAL
:
10285 case EXEC_OMP_FLUSH
:
10286 case EXEC_OMP_DISTRIBUTE
:
10287 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10288 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10289 case EXEC_OMP_DISTRIBUTE_SIMD
:
10291 case EXEC_OMP_DO_SIMD
:
10292 case EXEC_OMP_MASTER
:
10293 case EXEC_OMP_ORDERED
:
10294 case EXEC_OMP_SECTIONS
:
10295 case EXEC_OMP_SIMD
:
10296 case EXEC_OMP_SINGLE
:
10297 case EXEC_OMP_TARGET
:
10298 case EXEC_OMP_TARGET_DATA
:
10299 case EXEC_OMP_TARGET_TEAMS
:
10300 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10301 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10302 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10303 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10304 case EXEC_OMP_TARGET_UPDATE
:
10305 case EXEC_OMP_TASK
:
10306 case EXEC_OMP_TASKGROUP
:
10307 case EXEC_OMP_TASKWAIT
:
10308 case EXEC_OMP_TASKYIELD
:
10309 case EXEC_OMP_TEAMS
:
10310 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10311 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10312 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10313 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10314 case EXEC_OMP_WORKSHARE
:
10315 gfc_resolve_omp_directive (code
, ns
);
10318 case EXEC_OMP_PARALLEL
:
10319 case EXEC_OMP_PARALLEL_DO
:
10320 case EXEC_OMP_PARALLEL_DO_SIMD
:
10321 case EXEC_OMP_PARALLEL_SECTIONS
:
10322 case EXEC_OMP_PARALLEL_WORKSHARE
:
10323 omp_workshare_save
= omp_workshare_flag
;
10324 omp_workshare_flag
= 0;
10325 gfc_resolve_omp_directive (code
, ns
);
10326 omp_workshare_flag
= omp_workshare_save
;
10330 gfc_internal_error ("gfc_resolve_code(): Bad statement code");
10334 cs_base
= frame
.prev
;
10338 /* Resolve initial values and make sure they are compatible with
10342 resolve_values (gfc_symbol
*sym
)
10346 if (sym
->value
== NULL
)
10349 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10350 t
= resolve_structure_cons (sym
->value
, 1);
10352 t
= gfc_resolve_expr (sym
->value
);
10357 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10361 /* Verify any BIND(C) derived types in the namespace so we can report errors
10362 for them once, rather than for each variable declared of that type. */
10365 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10367 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10368 && derived_sym
->attr
.is_bind_c
== 1)
10369 verify_bind_c_derived_type (derived_sym
);
10375 /* Verify that any binding labels used in a given namespace do not collide
10376 with the names or binding labels of any global symbols. Multiple INTERFACE
10377 for the same procedure are permitted. */
10380 gfc_verify_binding_labels (gfc_symbol
*sym
)
10383 const char *module
;
10385 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10386 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10389 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10392 module
= sym
->module
;
10393 else if (sym
->ns
&& sym
->ns
->proc_name
10394 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10395 module
= sym
->ns
->proc_name
->name
;
10396 else if (sym
->ns
&& sym
->ns
->parent
10397 && sym
->ns
&& sym
->ns
->parent
->proc_name
10398 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10399 module
= sym
->ns
->parent
->proc_name
->name
;
10405 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10408 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10409 gsym
->where
= sym
->declared_at
;
10410 gsym
->sym_name
= sym
->name
;
10411 gsym
->binding_label
= sym
->binding_label
;
10412 gsym
->ns
= sym
->ns
;
10413 gsym
->mod_name
= module
;
10414 if (sym
->attr
.function
)
10415 gsym
->type
= GSYM_FUNCTION
;
10416 else if (sym
->attr
.subroutine
)
10417 gsym
->type
= GSYM_SUBROUTINE
;
10418 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10419 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10423 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10425 gfc_error_1 ("Variable %s with binding label %s at %L uses the same global "
10426 "identifier as entity at %L", sym
->name
,
10427 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10428 /* Clear the binding label to prevent checking multiple times. */
10429 sym
->binding_label
= NULL
;
10432 else if (sym
->attr
.flavor
== FL_VARIABLE
10433 && (strcmp (module
, gsym
->mod_name
) != 0
10434 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10436 /* This can only happen if the variable is defined in a module - if it
10437 isn't the same module, reject it. */
10438 gfc_error_1 ("Variable %s from module %s with binding label %s at %L uses "
10439 "the same global identifier as entity at %L from module %s",
10440 sym
->name
, module
, sym
->binding_label
,
10441 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10442 sym
->binding_label
= NULL
;
10444 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10445 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10446 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10447 && sym
!= gsym
->ns
->proc_name
10448 && (module
!= gsym
->mod_name
10449 || strcmp (gsym
->sym_name
, sym
->name
) != 0
10450 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10452 /* Print an error if the procedure is defined multiple times; we have to
10453 exclude references to the same procedure via module association or
10454 multiple checks for the same procedure. */
10455 gfc_error_1 ("Procedure %s with binding label %s at %L uses the same "
10456 "global identifier as entity at %L", sym
->name
,
10457 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10458 sym
->binding_label
= NULL
;
10463 /* Resolve an index expression. */
10466 resolve_index_expr (gfc_expr
*e
)
10468 if (!gfc_resolve_expr (e
))
10471 if (!gfc_simplify_expr (e
, 0))
10474 if (!gfc_specification_expr (e
))
10481 /* Resolve a charlen structure. */
10484 resolve_charlen (gfc_charlen
*cl
)
10487 bool saved_specification_expr
;
10493 saved_specification_expr
= specification_expr
;
10494 specification_expr
= true;
10496 if (cl
->length_from_typespec
)
10498 if (!gfc_resolve_expr (cl
->length
))
10500 specification_expr
= saved_specification_expr
;
10504 if (!gfc_simplify_expr (cl
->length
, 0))
10506 specification_expr
= saved_specification_expr
;
10513 if (!resolve_index_expr (cl
->length
))
10515 specification_expr
= saved_specification_expr
;
10520 /* "If the character length parameter value evaluates to a negative
10521 value, the length of character entities declared is zero." */
10522 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10524 if (warn_surprising
)
10525 gfc_warning_now (OPT_Wsurprising
,
10526 "CHARACTER variable at %L has negative length %d,"
10527 " the length has been set to zero",
10528 &cl
->length
->where
, i
);
10529 gfc_replace_expr (cl
->length
,
10530 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10533 /* Check that the character length is not too large. */
10534 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10535 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10536 && cl
->length
->ts
.type
== BT_INTEGER
10537 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10539 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10540 specification_expr
= saved_specification_expr
;
10544 specification_expr
= saved_specification_expr
;
10549 /* Test for non-constant shape arrays. */
10552 is_non_constant_shape_array (gfc_symbol
*sym
)
10558 not_constant
= false;
10559 if (sym
->as
!= NULL
)
10561 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10562 has not been simplified; parameter array references. Do the
10563 simplification now. */
10564 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10566 e
= sym
->as
->lower
[i
];
10567 if (e
&& (!resolve_index_expr(e
)
10568 || !gfc_is_constant_expr (e
)))
10569 not_constant
= true;
10570 e
= sym
->as
->upper
[i
];
10571 if (e
&& (!resolve_index_expr(e
)
10572 || !gfc_is_constant_expr (e
)))
10573 not_constant
= true;
10576 return not_constant
;
10579 /* Given a symbol and an initialization expression, add code to initialize
10580 the symbol to the function entry. */
10582 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10586 gfc_namespace
*ns
= sym
->ns
;
10588 /* Search for the function namespace if this is a contained
10589 function without an explicit result. */
10590 if (sym
->attr
.function
&& sym
== sym
->result
10591 && sym
->name
!= sym
->ns
->proc_name
->name
)
10593 ns
= ns
->contained
;
10594 for (;ns
; ns
= ns
->sibling
)
10595 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10601 gfc_free_expr (init
);
10605 /* Build an l-value expression for the result. */
10606 lval
= gfc_lval_expr_from_sym (sym
);
10608 /* Add the code at scope entry. */
10609 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10610 init_st
->next
= ns
->code
;
10611 ns
->code
= init_st
;
10613 /* Assign the default initializer to the l-value. */
10614 init_st
->loc
= sym
->declared_at
;
10615 init_st
->expr1
= lval
;
10616 init_st
->expr2
= init
;
10619 /* Assign the default initializer to a derived type variable or result. */
10622 apply_default_init (gfc_symbol
*sym
)
10624 gfc_expr
*init
= NULL
;
10626 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10629 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10630 init
= gfc_default_initializer (&sym
->ts
);
10632 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10635 build_init_assign (sym
, init
);
10636 sym
->attr
.referenced
= 1;
10639 /* Build an initializer for a local integer, real, complex, logical, or
10640 character variable, based on the command line flags finit-local-zero,
10641 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10642 null if the symbol should not have a default initialization. */
10644 build_default_init_expr (gfc_symbol
*sym
)
10647 gfc_expr
*init_expr
;
10650 /* These symbols should never have a default initialization. */
10651 if (sym
->attr
.allocatable
10652 || sym
->attr
.external
10654 || sym
->attr
.pointer
10655 || sym
->attr
.in_equivalence
10656 || sym
->attr
.in_common
10659 || sym
->attr
.cray_pointee
10660 || sym
->attr
.cray_pointer
10664 /* Now we'll try to build an initializer expression. */
10665 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10666 &sym
->declared_at
);
10668 /* We will only initialize integers, reals, complex, logicals, and
10669 characters, and only if the corresponding command-line flags
10670 were set. Otherwise, we free init_expr and return null. */
10671 switch (sym
->ts
.type
)
10674 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10675 mpz_set_si (init_expr
->value
.integer
,
10676 gfc_option
.flag_init_integer_value
);
10679 gfc_free_expr (init_expr
);
10685 switch (gfc_option
.flag_init_real
)
10687 case GFC_INIT_REAL_SNAN
:
10688 init_expr
->is_snan
= 1;
10689 /* Fall through. */
10690 case GFC_INIT_REAL_NAN
:
10691 mpfr_set_nan (init_expr
->value
.real
);
10694 case GFC_INIT_REAL_INF
:
10695 mpfr_set_inf (init_expr
->value
.real
, 1);
10698 case GFC_INIT_REAL_NEG_INF
:
10699 mpfr_set_inf (init_expr
->value
.real
, -1);
10702 case GFC_INIT_REAL_ZERO
:
10703 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10707 gfc_free_expr (init_expr
);
10714 switch (gfc_option
.flag_init_real
)
10716 case GFC_INIT_REAL_SNAN
:
10717 init_expr
->is_snan
= 1;
10718 /* Fall through. */
10719 case GFC_INIT_REAL_NAN
:
10720 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10721 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10724 case GFC_INIT_REAL_INF
:
10725 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10726 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10729 case GFC_INIT_REAL_NEG_INF
:
10730 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10731 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10734 case GFC_INIT_REAL_ZERO
:
10735 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10739 gfc_free_expr (init_expr
);
10746 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10747 init_expr
->value
.logical
= 0;
10748 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10749 init_expr
->value
.logical
= 1;
10752 gfc_free_expr (init_expr
);
10758 /* For characters, the length must be constant in order to
10759 create a default initializer. */
10760 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10761 && sym
->ts
.u
.cl
->length
10762 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10764 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10765 init_expr
->value
.character
.length
= char_len
;
10766 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10767 for (i
= 0; i
< char_len
; i
++)
10768 init_expr
->value
.character
.string
[i
]
10769 = (unsigned char) gfc_option
.flag_init_character_value
;
10773 gfc_free_expr (init_expr
);
10776 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10777 && sym
->ts
.u
.cl
->length
&& gfc_option
.flag_max_stack_var_size
!= 0)
10779 gfc_actual_arglist
*arg
;
10780 init_expr
= gfc_get_expr ();
10781 init_expr
->where
= sym
->declared_at
;
10782 init_expr
->ts
= sym
->ts
;
10783 init_expr
->expr_type
= EXPR_FUNCTION
;
10784 init_expr
->value
.function
.isym
=
10785 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10786 init_expr
->value
.function
.name
= "repeat";
10787 arg
= gfc_get_actual_arglist ();
10788 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10790 arg
->expr
->value
.character
.string
[0]
10791 = gfc_option
.flag_init_character_value
;
10792 arg
->next
= gfc_get_actual_arglist ();
10793 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10794 init_expr
->value
.function
.actual
= arg
;
10799 gfc_free_expr (init_expr
);
10805 /* Add an initialization expression to a local variable. */
10807 apply_default_init_local (gfc_symbol
*sym
)
10809 gfc_expr
*init
= NULL
;
10811 /* The symbol should be a variable or a function return value. */
10812 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10813 || (sym
->attr
.function
&& sym
->result
!= sym
))
10816 /* Try to build the initializer expression. If we can't initialize
10817 this symbol, then init will be NULL. */
10818 init
= build_default_init_expr (sym
);
10822 /* For saved variables, we don't want to add an initializer at function
10823 entry, so we just add a static initializer. Note that automatic variables
10824 are stack allocated even with -fno-automatic; we have also to exclude
10825 result variable, which are also nonstatic. */
10826 if (sym
->attr
.save
|| sym
->ns
->save_all
10827 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10828 && !sym
->ns
->proc_name
->attr
.recursive
10829 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10831 /* Don't clobber an existing initializer! */
10832 gcc_assert (sym
->value
== NULL
);
10837 build_init_assign (sym
, init
);
10841 /* Resolution of common features of flavors variable and procedure. */
10844 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10846 gfc_array_spec
*as
;
10848 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10849 as
= CLASS_DATA (sym
)->as
;
10853 /* Constraints on deferred shape variable. */
10854 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10856 bool pointer
, allocatable
, dimension
;
10858 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10860 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10861 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10862 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10866 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10867 allocatable
= sym
->attr
.allocatable
;
10868 dimension
= sym
->attr
.dimension
;
10873 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10875 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10876 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10879 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10880 "'%s' at %L may not be ALLOCATABLE",
10881 sym
->name
, &sym
->declared_at
))
10885 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10887 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10888 "assumed rank", sym
->name
, &sym
->declared_at
);
10894 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10895 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10897 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10898 sym
->name
, &sym
->declared_at
);
10903 /* Constraints on polymorphic variables. */
10904 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10907 if (sym
->attr
.class_ok
10908 && !sym
->attr
.select_type_temporary
10909 && !UNLIMITED_POLY (sym
)
10910 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10912 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10913 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10914 &sym
->declared_at
);
10919 /* Assume that use associated symbols were checked in the module ns.
10920 Class-variables that are associate-names are also something special
10921 and excepted from the test. */
10922 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10924 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10925 "or pointer", sym
->name
, &sym
->declared_at
);
10934 /* Additional checks for symbols with flavor variable and derived
10935 type. To be called from resolve_fl_variable. */
10938 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10940 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10942 /* Check to see if a derived type is blocked from being host
10943 associated by the presence of another class I symbol in the same
10944 namespace. 14.6.1.3 of the standard and the discussion on
10945 comp.lang.fortran. */
10946 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10947 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10950 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10951 if (s
&& s
->attr
.generic
)
10952 s
= gfc_find_dt_in_generic (s
);
10953 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10955 gfc_error_1 ("The type '%s' cannot be host associated at %L "
10956 "because it is blocked by an incompatible object "
10957 "of the same name declared at %L",
10958 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10964 /* 4th constraint in section 11.3: "If an object of a type for which
10965 component-initialization is specified (R429) appears in the
10966 specification-part of a module and does not have the ALLOCATABLE
10967 or POINTER attribute, the object shall have the SAVE attribute."
10969 The check for initializers is performed with
10970 gfc_has_default_initializer because gfc_default_initializer generates
10971 a hidden default for allocatable components. */
10972 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10973 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10974 && !sym
->ns
->save_all
&& !sym
->attr
.save
10975 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10976 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10977 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10978 "'%s' at %L, needed due to the default "
10979 "initialization", sym
->name
, &sym
->declared_at
))
10982 /* Assign default initializer. */
10983 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10984 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10986 sym
->value
= gfc_default_initializer (&sym
->ts
);
10993 /* Resolve symbols with flavor variable. */
10996 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10998 int no_init_flag
, automatic_flag
;
11000 const char *auto_save_msg
;
11001 bool saved_specification_expr
;
11003 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
11006 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
11009 /* Set this flag to check that variables are parameters of all entries.
11010 This check is effected by the call to gfc_resolve_expr through
11011 is_non_constant_shape_array. */
11012 saved_specification_expr
= specification_expr
;
11013 specification_expr
= true;
11015 if (sym
->ns
->proc_name
11016 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11017 || sym
->ns
->proc_name
->attr
.is_main_program
)
11018 && !sym
->attr
.use_assoc
11019 && !sym
->attr
.allocatable
11020 && !sym
->attr
.pointer
11021 && is_non_constant_shape_array (sym
))
11023 /* The shape of a main program or module array needs to be
11025 gfc_error ("The module or main program array '%s' at %L must "
11026 "have constant shape", sym
->name
, &sym
->declared_at
);
11027 specification_expr
= saved_specification_expr
;
11031 /* Constraints on deferred type parameter. */
11032 if (sym
->ts
.deferred
11033 && !(sym
->attr
.pointer
11034 || sym
->attr
.allocatable
11035 || sym
->attr
.omp_udr_artificial_var
))
11037 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
11038 "requires either the pointer or allocatable attribute",
11039 sym
->name
, &sym
->declared_at
);
11040 specification_expr
= saved_specification_expr
;
11044 if (sym
->ts
.type
== BT_CHARACTER
)
11046 /* Make sure that character string variables with assumed length are
11047 dummy arguments. */
11048 e
= sym
->ts
.u
.cl
->length
;
11049 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11050 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
11051 && !sym
->attr
.omp_udr_artificial_var
)
11053 gfc_error ("Entity with assumed character length at %L must be a "
11054 "dummy argument or a PARAMETER", &sym
->declared_at
);
11055 specification_expr
= saved_specification_expr
;
11059 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11061 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11062 specification_expr
= saved_specification_expr
;
11066 if (!gfc_is_constant_expr (e
)
11067 && !(e
->expr_type
== EXPR_VARIABLE
11068 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11070 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11071 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11072 || sym
->ns
->proc_name
->attr
.is_main_program
))
11074 gfc_error ("'%s' at %L must have constant character length "
11075 "in this context", sym
->name
, &sym
->declared_at
);
11076 specification_expr
= saved_specification_expr
;
11079 if (sym
->attr
.in_common
)
11081 gfc_error ("COMMON variable '%s' at %L must have constant "
11082 "character length", sym
->name
, &sym
->declared_at
);
11083 specification_expr
= saved_specification_expr
;
11089 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11090 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11092 /* Determine if the symbol may not have an initializer. */
11093 no_init_flag
= automatic_flag
= 0;
11094 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11095 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11097 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11098 && is_non_constant_shape_array (sym
))
11100 no_init_flag
= automatic_flag
= 1;
11102 /* Also, they must not have the SAVE attribute.
11103 SAVE_IMPLICIT is checked below. */
11104 if (sym
->as
&& sym
->attr
.codimension
)
11106 int corank
= sym
->as
->corank
;
11107 sym
->as
->corank
= 0;
11108 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11109 sym
->as
->corank
= corank
;
11111 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11113 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11114 specification_expr
= saved_specification_expr
;
11119 /* Ensure that any initializer is simplified. */
11121 gfc_simplify_expr (sym
->value
, 1);
11123 /* Reject illegal initializers. */
11124 if (!sym
->mark
&& sym
->value
)
11126 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11127 && CLASS_DATA (sym
)->attr
.allocatable
))
11128 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
11129 sym
->name
, &sym
->declared_at
);
11130 else if (sym
->attr
.external
)
11131 gfc_error ("External '%s' at %L cannot have an initializer",
11132 sym
->name
, &sym
->declared_at
);
11133 else if (sym
->attr
.dummy
11134 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11135 gfc_error ("Dummy '%s' at %L cannot have an initializer",
11136 sym
->name
, &sym
->declared_at
);
11137 else if (sym
->attr
.intrinsic
)
11138 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
11139 sym
->name
, &sym
->declared_at
);
11140 else if (sym
->attr
.result
)
11141 gfc_error ("Function result '%s' at %L cannot have an initializer",
11142 sym
->name
, &sym
->declared_at
);
11143 else if (automatic_flag
)
11144 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
11145 sym
->name
, &sym
->declared_at
);
11147 goto no_init_error
;
11148 specification_expr
= saved_specification_expr
;
11153 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11155 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11156 specification_expr
= saved_specification_expr
;
11160 specification_expr
= saved_specification_expr
;
11165 /* Resolve a procedure. */
11168 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11170 gfc_formal_arglist
*arg
;
11172 if (sym
->attr
.function
11173 && !resolve_fl_var_and_proc (sym
, mp_flag
))
11176 if (sym
->ts
.type
== BT_CHARACTER
)
11178 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11180 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11181 && !resolve_charlen (cl
))
11184 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11185 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11187 gfc_error ("Character-valued statement function '%s' at %L must "
11188 "have constant length", sym
->name
, &sym
->declared_at
);
11193 /* Ensure that derived type for are not of a private type. Internal
11194 module procedures are excluded by 2.2.3.3 - i.e., they are not
11195 externally accessible and can access all the objects accessible in
11197 if (!(sym
->ns
->parent
11198 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11199 && gfc_check_symbol_access (sym
))
11201 gfc_interface
*iface
;
11203 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11206 && arg
->sym
->ts
.type
== BT_DERIVED
11207 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11208 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11209 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
11210 "and cannot be a dummy argument"
11211 " of '%s', which is PUBLIC at %L",
11212 arg
->sym
->name
, sym
->name
,
11213 &sym
->declared_at
))
11215 /* Stop this message from recurring. */
11216 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11221 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11222 PRIVATE to the containing module. */
11223 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11225 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11228 && arg
->sym
->ts
.type
== BT_DERIVED
11229 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11230 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11231 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
11232 "PUBLIC interface '%s' at %L "
11233 "takes dummy arguments of '%s' which "
11234 "is PRIVATE", iface
->sym
->name
,
11235 sym
->name
, &iface
->sym
->declared_at
,
11236 gfc_typename(&arg
->sym
->ts
)))
11238 /* Stop this message from recurring. */
11239 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11246 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11247 && !sym
->attr
.proc_pointer
)
11249 gfc_error ("Function '%s' at %L cannot have an initializer",
11250 sym
->name
, &sym
->declared_at
);
11254 /* An external symbol may not have an initializer because it is taken to be
11255 a procedure. Exception: Procedure Pointers. */
11256 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11258 gfc_error ("External object '%s' at %L may not have an initializer",
11259 sym
->name
, &sym
->declared_at
);
11263 /* An elemental function is required to return a scalar 12.7.1 */
11264 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11266 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11267 "result", sym
->name
, &sym
->declared_at
);
11268 /* Reset so that the error only occurs once. */
11269 sym
->attr
.elemental
= 0;
11273 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11274 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11276 gfc_error ("Statement function '%s' at %L may not have pointer or "
11277 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11281 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11282 char-len-param shall not be array-valued, pointer-valued, recursive
11283 or pure. ....snip... A character value of * may only be used in the
11284 following ways: (i) Dummy arg of procedure - dummy associates with
11285 actual length; (ii) To declare a named constant; or (iii) External
11286 function - but length must be declared in calling scoping unit. */
11287 if (sym
->attr
.function
11288 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11289 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11291 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11292 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11294 if (sym
->as
&& sym
->as
->rank
)
11295 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11296 "array-valued", sym
->name
, &sym
->declared_at
);
11298 if (sym
->attr
.pointer
)
11299 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11300 "pointer-valued", sym
->name
, &sym
->declared_at
);
11302 if (sym
->attr
.pure
)
11303 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11304 "pure", sym
->name
, &sym
->declared_at
);
11306 if (sym
->attr
.recursive
)
11307 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11308 "recursive", sym
->name
, &sym
->declared_at
);
11313 /* Appendix B.2 of the standard. Contained functions give an
11314 error anyway. Deferred character length is an F2003 feature.
11315 Don't warn on intrinsic conversion functions, which start
11316 with two underscores. */
11317 if (!sym
->attr
.contained
&& !sym
->ts
.deferred
11318 && (sym
->name
[0] != '_' || sym
->name
[1] != '_'))
11319 gfc_notify_std (GFC_STD_F95_OBS
,
11320 "CHARACTER(*) function '%s' at %L",
11321 sym
->name
, &sym
->declared_at
);
11324 /* F2008, C1218. */
11325 if (sym
->attr
.elemental
)
11327 if (sym
->attr
.proc_pointer
)
11329 gfc_error ("Procedure pointer '%s' at %L shall not be elemental",
11330 sym
->name
, &sym
->declared_at
);
11333 if (sym
->attr
.dummy
)
11335 gfc_error ("Dummy procedure '%s' at %L shall not be elemental",
11336 sym
->name
, &sym
->declared_at
);
11341 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11343 gfc_formal_arglist
*curr_arg
;
11344 int has_non_interop_arg
= 0;
11346 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11347 sym
->common_block
))
11349 /* Clear these to prevent looking at them again if there was an
11351 sym
->attr
.is_bind_c
= 0;
11352 sym
->attr
.is_c_interop
= 0;
11353 sym
->ts
.is_c_interop
= 0;
11357 /* So far, no errors have been found. */
11358 sym
->attr
.is_c_interop
= 1;
11359 sym
->ts
.is_c_interop
= 1;
11362 curr_arg
= gfc_sym_get_dummy_args (sym
);
11363 while (curr_arg
!= NULL
)
11365 /* Skip implicitly typed dummy args here. */
11366 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11367 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11368 /* If something is found to fail, record the fact so we
11369 can mark the symbol for the procedure as not being
11370 BIND(C) to try and prevent multiple errors being
11372 has_non_interop_arg
= 1;
11374 curr_arg
= curr_arg
->next
;
11377 /* See if any of the arguments were not interoperable and if so, clear
11378 the procedure symbol to prevent duplicate error messages. */
11379 if (has_non_interop_arg
!= 0)
11381 sym
->attr
.is_c_interop
= 0;
11382 sym
->ts
.is_c_interop
= 0;
11383 sym
->attr
.is_bind_c
= 0;
11387 if (!sym
->attr
.proc_pointer
)
11389 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11391 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11392 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11395 if (sym
->attr
.intent
)
11397 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11398 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11401 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11403 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11404 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11407 if (sym
->attr
.external
&& sym
->attr
.function
11408 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11409 || sym
->attr
.contained
))
11411 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11412 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11415 if (strcmp ("ppr@", sym
->name
) == 0)
11417 gfc_error ("Procedure pointer result '%s' at %L "
11418 "is missing the pointer attribute",
11419 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11428 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11429 been defined and we now know their defined arguments, check that they fulfill
11430 the requirements of the standard for procedures used as finalizers. */
11433 gfc_resolve_finalizers (gfc_symbol
* derived
, bool *finalizable
)
11435 gfc_finalizer
* list
;
11436 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11437 bool result
= true;
11438 bool seen_scalar
= false;
11441 gfc_symbol
*parent
= gfc_get_derived_super_type (derived
);
11444 gfc_resolve_finalizers (parent
, finalizable
);
11446 /* Return early when not finalizable. Additionally, ensure that derived-type
11447 components have a their finalizables resolved. */
11448 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11450 bool has_final
= false;
11451 for (c
= derived
->components
; c
; c
= c
->next
)
11452 if (c
->ts
.type
== BT_DERIVED
11453 && !c
->attr
.pointer
&& !c
->attr
.proc_pointer
&& !c
->attr
.allocatable
)
11455 bool has_final2
= false;
11456 if (!gfc_resolve_finalizers (c
->ts
.u
.derived
, &has_final
))
11457 return false; /* Error. */
11458 has_final
= has_final
|| has_final2
;
11463 *finalizable
= false;
11468 /* Walk over the list of finalizer-procedures, check them, and if any one
11469 does not fit in with the standard's definition, print an error and remove
11470 it from the list. */
11471 prev_link
= &derived
->f2k_derived
->finalizers
;
11472 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11474 gfc_formal_arglist
*dummy_args
;
11479 /* Skip this finalizer if we already resolved it. */
11480 if (list
->proc_tree
)
11482 prev_link
= &(list
->next
);
11486 /* Check this exists and is a SUBROUTINE. */
11487 if (!list
->proc_sym
->attr
.subroutine
)
11489 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11490 list
->proc_sym
->name
, &list
->where
);
11494 /* We should have exactly one argument. */
11495 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11496 if (!dummy_args
|| dummy_args
->next
)
11498 gfc_error ("FINAL procedure at %L must have exactly one argument",
11502 arg
= dummy_args
->sym
;
11504 /* This argument must be of our type. */
11505 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11507 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11508 &arg
->declared_at
, derived
->name
);
11512 /* It must neither be a pointer nor allocatable nor optional. */
11513 if (arg
->attr
.pointer
)
11515 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11516 &arg
->declared_at
);
11519 if (arg
->attr
.allocatable
)
11521 gfc_error ("Argument of FINAL procedure at %L must not be"
11522 " ALLOCATABLE", &arg
->declared_at
);
11525 if (arg
->attr
.optional
)
11527 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11528 &arg
->declared_at
);
11532 /* It must not be INTENT(OUT). */
11533 if (arg
->attr
.intent
== INTENT_OUT
)
11535 gfc_error ("Argument of FINAL procedure at %L must not be"
11536 " INTENT(OUT)", &arg
->declared_at
);
11540 /* Warn if the procedure is non-scalar and not assumed shape. */
11541 if (warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11542 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11543 gfc_warning (OPT_Wsurprising
,
11544 "Non-scalar FINAL procedure at %L should have assumed"
11545 " shape argument", &arg
->declared_at
);
11547 /* Check that it does not match in kind and rank with a FINAL procedure
11548 defined earlier. To really loop over the *earlier* declarations,
11549 we need to walk the tail of the list as new ones were pushed at the
11551 /* TODO: Handle kind parameters once they are implemented. */
11552 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11553 for (i
= list
->next
; i
; i
= i
->next
)
11555 gfc_formal_arglist
*dummy_args
;
11557 /* Argument list might be empty; that is an error signalled earlier,
11558 but we nevertheless continued resolving. */
11559 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11562 gfc_symbol
* i_arg
= dummy_args
->sym
;
11563 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11564 if (i_rank
== my_rank
)
11566 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11567 " rank (%d) as '%s'",
11568 list
->proc_sym
->name
, &list
->where
, my_rank
,
11569 i
->proc_sym
->name
);
11575 /* Is this the/a scalar finalizer procedure? */
11576 if (!arg
->as
|| arg
->as
->rank
== 0)
11577 seen_scalar
= true;
11579 /* Find the symtree for this procedure. */
11580 gcc_assert (!list
->proc_tree
);
11581 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11583 prev_link
= &list
->next
;
11586 /* Remove wrong nodes immediately from the list so we don't risk any
11587 troubles in the future when they might fail later expectations. */
11590 *prev_link
= list
->next
;
11591 gfc_free_finalizer (i
);
11595 if (result
== false)
11598 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11599 were nodes in the list, must have been for arrays. It is surely a good
11600 idea to have a scalar version there if there's something to finalize. */
11601 if (warn_surprising
&& result
&& !seen_scalar
)
11602 gfc_warning (OPT_Wsurprising
,
11603 "Only array FINAL procedures declared for derived type %qs"
11604 " defined at %L, suggest also scalar one",
11605 derived
->name
, &derived
->declared_at
);
11607 vtab
= gfc_find_derived_vtab (derived
);
11608 c
= vtab
->ts
.u
.derived
->components
->next
->next
->next
->next
->next
;
11609 gfc_set_sym_referenced (c
->initializer
->symtree
->n
.sym
);
11612 *finalizable
= true;
11618 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11621 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11622 const char* generic_name
, locus where
)
11624 gfc_symbol
*sym1
, *sym2
;
11625 const char *pass1
, *pass2
;
11626 gfc_formal_arglist
*dummy_args
;
11628 gcc_assert (t1
->specific
&& t2
->specific
);
11629 gcc_assert (!t1
->specific
->is_generic
);
11630 gcc_assert (!t2
->specific
->is_generic
);
11631 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11633 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11634 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11639 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11640 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11641 || sym1
->attr
.function
!= sym2
->attr
.function
)
11643 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11644 " GENERIC '%s' at %L",
11645 sym1
->name
, sym2
->name
, generic_name
, &where
);
11649 /* Determine PASS arguments. */
11650 if (t1
->specific
->nopass
)
11652 else if (t1
->specific
->pass_arg
)
11653 pass1
= t1
->specific
->pass_arg
;
11656 dummy_args
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
);
11658 pass1
= dummy_args
->sym
->name
;
11662 if (t2
->specific
->nopass
)
11664 else if (t2
->specific
->pass_arg
)
11665 pass2
= t2
->specific
->pass_arg
;
11668 dummy_args
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
);
11670 pass2
= dummy_args
->sym
->name
;
11675 /* Compare the interfaces. */
11676 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11677 NULL
, 0, pass1
, pass2
))
11679 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11680 sym1
->name
, sym2
->name
, generic_name
, &where
);
11688 /* Worker function for resolving a generic procedure binding; this is used to
11689 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11691 The difference between those cases is finding possible inherited bindings
11692 that are overridden, as one has to look for them in tb_sym_root,
11693 tb_uop_root or tb_op, respectively. Thus the caller must already find
11694 the super-type and set p->overridden correctly. */
11697 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11698 gfc_typebound_proc
* p
, const char* name
)
11700 gfc_tbp_generic
* target
;
11701 gfc_symtree
* first_target
;
11702 gfc_symtree
* inherited
;
11704 gcc_assert (p
&& p
->is_generic
);
11706 /* Try to find the specific bindings for the symtrees in our target-list. */
11707 gcc_assert (p
->u
.generic
);
11708 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11709 if (!target
->specific
)
11711 gfc_typebound_proc
* overridden_tbp
;
11712 gfc_tbp_generic
* g
;
11713 const char* target_name
;
11715 target_name
= target
->specific_st
->name
;
11717 /* Defined for this type directly. */
11718 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11720 target
->specific
= target
->specific_st
->n
.tb
;
11721 goto specific_found
;
11724 /* Look for an inherited specific binding. */
11727 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11732 gcc_assert (inherited
->n
.tb
);
11733 target
->specific
= inherited
->n
.tb
;
11734 goto specific_found
;
11738 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11739 " at %L", target_name
, name
, &p
->where
);
11742 /* Once we've found the specific binding, check it is not ambiguous with
11743 other specifics already found or inherited for the same GENERIC. */
11745 gcc_assert (target
->specific
);
11747 /* This must really be a specific binding! */
11748 if (target
->specific
->is_generic
)
11750 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11751 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11755 /* Check those already resolved on this type directly. */
11756 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11757 if (g
!= target
&& g
->specific
11758 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11761 /* Check for ambiguity with inherited specific targets. */
11762 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11763 overridden_tbp
= overridden_tbp
->overridden
)
11764 if (overridden_tbp
->is_generic
)
11766 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11768 gcc_assert (g
->specific
);
11769 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11775 /* If we attempt to "overwrite" a specific binding, this is an error. */
11776 if (p
->overridden
&& !p
->overridden
->is_generic
)
11778 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11779 " the same name", name
, &p
->where
);
11783 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11784 all must have the same attributes here. */
11785 first_target
= p
->u
.generic
->specific
->u
.specific
;
11786 gcc_assert (first_target
);
11787 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11788 p
->function
= first_target
->n
.sym
->attr
.function
;
11794 /* Resolve a GENERIC procedure binding for a derived type. */
11797 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11799 gfc_symbol
* super_type
;
11801 /* Find the overridden binding if any. */
11802 st
->n
.tb
->overridden
= NULL
;
11803 super_type
= gfc_get_derived_super_type (derived
);
11806 gfc_symtree
* overridden
;
11807 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11810 if (overridden
&& overridden
->n
.tb
)
11811 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11814 /* Resolve using worker function. */
11815 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11819 /* Retrieve the target-procedure of an operator binding and do some checks in
11820 common for intrinsic and user-defined type-bound operators. */
11823 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11825 gfc_symbol
* target_proc
;
11827 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11828 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11829 gcc_assert (target_proc
);
11831 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11832 if (target
->specific
->nopass
)
11834 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11838 return target_proc
;
11842 /* Resolve a type-bound intrinsic operator. */
11845 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11846 gfc_typebound_proc
* p
)
11848 gfc_symbol
* super_type
;
11849 gfc_tbp_generic
* target
;
11851 /* If there's already an error here, do nothing (but don't fail again). */
11855 /* Operators should always be GENERIC bindings. */
11856 gcc_assert (p
->is_generic
);
11858 /* Look for an overridden binding. */
11859 super_type
= gfc_get_derived_super_type (derived
);
11860 if (super_type
&& super_type
->f2k_derived
)
11861 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11864 p
->overridden
= NULL
;
11866 /* Resolve general GENERIC properties using worker function. */
11867 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11870 /* Check the targets to be procedures of correct interface. */
11871 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11873 gfc_symbol
* target_proc
;
11875 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11879 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11882 /* Add target to non-typebound operator list. */
11883 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11884 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11886 gfc_interface
*head
, *intr
;
11887 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11889 head
= derived
->ns
->op
[op
];
11890 intr
= gfc_get_interface ();
11891 intr
->sym
= target_proc
;
11892 intr
->where
= p
->where
;
11894 derived
->ns
->op
[op
] = intr
;
11906 /* Resolve a type-bound user operator (tree-walker callback). */
11908 static gfc_symbol
* resolve_bindings_derived
;
11909 static bool resolve_bindings_result
;
11911 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11914 resolve_typebound_user_op (gfc_symtree
* stree
)
11916 gfc_symbol
* super_type
;
11917 gfc_tbp_generic
* target
;
11919 gcc_assert (stree
&& stree
->n
.tb
);
11921 if (stree
->n
.tb
->error
)
11924 /* Operators should always be GENERIC bindings. */
11925 gcc_assert (stree
->n
.tb
->is_generic
);
11927 /* Find overridden procedure, if any. */
11928 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11929 if (super_type
&& super_type
->f2k_derived
)
11931 gfc_symtree
* overridden
;
11932 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11933 stree
->name
, true, NULL
);
11935 if (overridden
&& overridden
->n
.tb
)
11936 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11939 stree
->n
.tb
->overridden
= NULL
;
11941 /* Resolve basically using worker function. */
11942 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11945 /* Check the targets to be functions of correct interface. */
11946 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11948 gfc_symbol
* target_proc
;
11950 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11954 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11961 resolve_bindings_result
= false;
11962 stree
->n
.tb
->error
= 1;
11966 /* Resolve the type-bound procedures for a derived type. */
11969 resolve_typebound_procedure (gfc_symtree
* stree
)
11973 gfc_symbol
* me_arg
;
11974 gfc_symbol
* super_type
;
11975 gfc_component
* comp
;
11977 gcc_assert (stree
);
11979 /* Undefined specific symbol from GENERIC target definition. */
11983 if (stree
->n
.tb
->error
)
11986 /* If this is a GENERIC binding, use that routine. */
11987 if (stree
->n
.tb
->is_generic
)
11989 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11994 /* Get the target-procedure to check it. */
11995 gcc_assert (!stree
->n
.tb
->is_generic
);
11996 gcc_assert (stree
->n
.tb
->u
.specific
);
11997 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11998 where
= stree
->n
.tb
->where
;
12000 /* Default access should already be resolved from the parser. */
12001 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12003 if (stree
->n
.tb
->deferred
)
12005 if (!check_proc_interface (proc
, &where
))
12010 /* Check for F08:C465. */
12011 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12012 || (proc
->attr
.proc
!= PROC_MODULE
12013 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12014 || proc
->attr
.abstract
)
12016 gfc_error ("'%s' must be a module procedure or an external procedure with"
12017 " an explicit interface at %L", proc
->name
, &where
);
12022 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12023 stree
->n
.tb
->function
= proc
->attr
.function
;
12025 /* Find the super-type of the current derived type. We could do this once and
12026 store in a global if speed is needed, but as long as not I believe this is
12027 more readable and clearer. */
12028 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12030 /* If PASS, resolve and check arguments if not already resolved / loaded
12031 from a .mod file. */
12032 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12034 gfc_formal_arglist
*dummy_args
;
12036 dummy_args
= gfc_sym_get_dummy_args (proc
);
12037 if (stree
->n
.tb
->pass_arg
)
12039 gfc_formal_arglist
*i
;
12041 /* If an explicit passing argument name is given, walk the arg-list
12042 and look for it. */
12045 stree
->n
.tb
->pass_arg_num
= 1;
12046 for (i
= dummy_args
; i
; i
= i
->next
)
12048 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12053 ++stree
->n
.tb
->pass_arg_num
;
12058 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
12060 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12061 stree
->n
.tb
->pass_arg
);
12067 /* Otherwise, take the first one; there should in fact be at least
12069 stree
->n
.tb
->pass_arg_num
= 1;
12072 gfc_error ("Procedure '%s' with PASS at %L must have at"
12073 " least one argument", proc
->name
, &where
);
12076 me_arg
= dummy_args
->sym
;
12079 /* Now check that the argument-type matches and the passed-object
12080 dummy argument is generally fine. */
12082 gcc_assert (me_arg
);
12084 if (me_arg
->ts
.type
!= BT_CLASS
)
12086 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12087 " at %L", proc
->name
, &where
);
12091 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12092 != resolve_bindings_derived
)
12094 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12095 " the derived-type '%s'", me_arg
->name
, proc
->name
,
12096 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12100 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12101 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12103 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
12104 " scalar", proc
->name
, &where
);
12107 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12109 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12110 " be ALLOCATABLE", proc
->name
, &where
);
12113 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12115 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12116 " be POINTER", proc
->name
, &where
);
12121 /* If we are extending some type, check that we don't override a procedure
12122 flagged NON_OVERRIDABLE. */
12123 stree
->n
.tb
->overridden
= NULL
;
12126 gfc_symtree
* overridden
;
12127 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12128 stree
->name
, true, NULL
);
12132 if (overridden
->n
.tb
)
12133 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12135 if (!gfc_check_typebound_override (stree
, overridden
))
12140 /* See if there's a name collision with a component directly in this type. */
12141 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12142 if (!strcmp (comp
->name
, stree
->name
))
12144 gfc_error ("Procedure '%s' at %L has the same name as a component of"
12146 stree
->name
, &where
, resolve_bindings_derived
->name
);
12150 /* Try to find a name collision with an inherited component. */
12151 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12153 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
12154 " component of '%s'",
12155 stree
->name
, &where
, resolve_bindings_derived
->name
);
12159 stree
->n
.tb
->error
= 0;
12163 resolve_bindings_result
= false;
12164 stree
->n
.tb
->error
= 1;
12169 resolve_typebound_procedures (gfc_symbol
* derived
)
12172 gfc_symbol
* super_type
;
12174 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12177 super_type
= gfc_get_derived_super_type (derived
);
12179 resolve_symbol (super_type
);
12181 resolve_bindings_derived
= derived
;
12182 resolve_bindings_result
= true;
12184 if (derived
->f2k_derived
->tb_sym_root
)
12185 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12186 &resolve_typebound_procedure
);
12188 if (derived
->f2k_derived
->tb_uop_root
)
12189 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12190 &resolve_typebound_user_op
);
12192 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12194 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12195 if (p
&& !resolve_typebound_intrinsic_op (derived
,
12196 (gfc_intrinsic_op
)op
, p
))
12197 resolve_bindings_result
= false;
12200 return resolve_bindings_result
;
12204 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12205 to give all identical derived types the same backend_decl. */
12207 add_dt_to_dt_list (gfc_symbol
*derived
)
12209 gfc_dt_list
*dt_list
;
12211 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12212 if (derived
== dt_list
->derived
)
12215 dt_list
= gfc_get_dt_list ();
12216 dt_list
->next
= gfc_derived_types
;
12217 dt_list
->derived
= derived
;
12218 gfc_derived_types
= dt_list
;
12222 /* Ensure that a derived-type is really not abstract, meaning that every
12223 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12226 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12231 if (!ensure_not_abstract_walker (sub
, st
->left
))
12233 if (!ensure_not_abstract_walker (sub
, st
->right
))
12236 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12238 gfc_symtree
* overriding
;
12239 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12242 gcc_assert (overriding
->n
.tb
);
12243 if (overriding
->n
.tb
->deferred
)
12245 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
12246 " '%s' is DEFERRED and not overridden",
12247 sub
->name
, &sub
->declared_at
, st
->name
);
12256 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12258 /* The algorithm used here is to recursively travel up the ancestry of sub
12259 and for each ancestor-type, check all bindings. If any of them is
12260 DEFERRED, look it up starting from sub and see if the found (overriding)
12261 binding is not DEFERRED.
12262 This is not the most efficient way to do this, but it should be ok and is
12263 clearer than something sophisticated. */
12265 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12267 if (!ancestor
->attr
.abstract
)
12270 /* Walk bindings of this ancestor. */
12271 if (ancestor
->f2k_derived
)
12274 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12279 /* Find next ancestor type and recurse on it. */
12280 ancestor
= gfc_get_derived_super_type (ancestor
);
12282 return ensure_not_abstract (sub
, ancestor
);
12288 /* This check for typebound defined assignments is done recursively
12289 since the order in which derived types are resolved is not always in
12290 order of the declarations. */
12293 check_defined_assignments (gfc_symbol
*derived
)
12297 for (c
= derived
->components
; c
; c
= c
->next
)
12299 if (c
->ts
.type
!= BT_DERIVED
12301 || c
->attr
.allocatable
12302 || c
->attr
.proc_pointer_comp
12303 || c
->attr
.class_pointer
12304 || c
->attr
.proc_pointer
)
12307 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12308 || (c
->ts
.u
.derived
->f2k_derived
12309 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12311 derived
->attr
.defined_assign_comp
= 1;
12315 check_defined_assignments (c
->ts
.u
.derived
);
12316 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12318 derived
->attr
.defined_assign_comp
= 1;
12325 /* Resolve the components of a derived type. This does not have to wait until
12326 resolution stage, but can be done as soon as the dt declaration has been
12330 resolve_fl_derived0 (gfc_symbol
*sym
)
12332 gfc_symbol
* super_type
;
12335 if (sym
->attr
.unlimited_polymorphic
)
12338 super_type
= gfc_get_derived_super_type (sym
);
12341 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12343 gfc_error ("As extending type '%s' at %L has a coarray component, "
12344 "parent type '%s' shall also have one", sym
->name
,
12345 &sym
->declared_at
, super_type
->name
);
12349 /* Ensure the extended type gets resolved before we do. */
12350 if (super_type
&& !resolve_fl_derived0 (super_type
))
12353 /* An ABSTRACT type must be extensible. */
12354 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12356 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12357 sym
->name
, &sym
->declared_at
);
12361 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12364 for ( ; c
!= NULL
; c
= c
->next
)
12366 if (c
->attr
.artificial
)
12370 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12371 && c
->attr
.codimension
12372 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12374 gfc_error ("Coarray component %qs at %L must be allocatable with "
12375 "deferred shape", c
->name
, &c
->loc
);
12380 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12381 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12383 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12384 "shall not be a coarray", c
->name
, &c
->loc
);
12389 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12390 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12391 || c
->attr
.allocatable
))
12393 gfc_error ("Component %qs at %L with coarray component "
12394 "shall be a nonpointer, nonallocatable scalar",
12400 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12402 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
12403 "is not an array pointer", c
->name
, &c
->loc
);
12407 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12409 gfc_symbol
*ifc
= c
->ts
.interface
;
12411 if (!sym
->attr
.vtype
12412 && !check_proc_interface (ifc
, &c
->loc
))
12415 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12417 /* Resolve interface and copy attributes. */
12418 if (ifc
->formal
&& !ifc
->formal_ns
)
12419 resolve_symbol (ifc
);
12420 if (ifc
->attr
.intrinsic
)
12421 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12425 c
->ts
= ifc
->result
->ts
;
12426 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12427 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12428 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12429 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12430 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12435 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12436 c
->attr
.pointer
= ifc
->attr
.pointer
;
12437 c
->attr
.dimension
= ifc
->attr
.dimension
;
12438 c
->as
= gfc_copy_array_spec (ifc
->as
);
12439 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12441 c
->ts
.interface
= ifc
;
12442 c
->attr
.function
= ifc
->attr
.function
;
12443 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12445 c
->attr
.pure
= ifc
->attr
.pure
;
12446 c
->attr
.elemental
= ifc
->attr
.elemental
;
12447 c
->attr
.recursive
= ifc
->attr
.recursive
;
12448 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12449 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12450 /* Copy char length. */
12451 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12453 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12454 if (cl
->length
&& !cl
->resolved
12455 && !gfc_resolve_expr (cl
->length
))
12461 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12463 /* Since PPCs are not implicitly typed, a PPC without an explicit
12464 interface must be a subroutine. */
12465 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12468 /* Procedure pointer components: Check PASS arg. */
12469 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12470 && !sym
->attr
.vtype
)
12472 gfc_symbol
* me_arg
;
12474 if (c
->tb
->pass_arg
)
12476 gfc_formal_arglist
* i
;
12478 /* If an explicit passing argument name is given, walk the arg-list
12479 and look for it. */
12482 c
->tb
->pass_arg_num
= 1;
12483 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12485 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12490 c
->tb
->pass_arg_num
++;
12495 gfc_error ("Procedure pointer component %qs with PASS(%s) "
12496 "at %L has no argument %qs", c
->name
,
12497 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12504 /* Otherwise, take the first one; there should in fact be at least
12506 c
->tb
->pass_arg_num
= 1;
12507 if (!c
->ts
.interface
->formal
)
12509 gfc_error ("Procedure pointer component %qs with PASS at %L "
12510 "must have at least one argument",
12515 me_arg
= c
->ts
.interface
->formal
->sym
;
12518 /* Now check that the argument-type matches. */
12519 gcc_assert (me_arg
);
12520 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12521 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12522 || (me_arg
->ts
.type
== BT_CLASS
12523 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12525 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
12526 " the derived type %qs", me_arg
->name
, c
->name
,
12527 me_arg
->name
, &c
->loc
, sym
->name
);
12532 /* Check for C453. */
12533 if (me_arg
->attr
.dimension
)
12535 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12536 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12542 if (me_arg
->attr
.pointer
)
12544 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12545 "may not have the POINTER attribute", me_arg
->name
,
12546 c
->name
, me_arg
->name
, &c
->loc
);
12551 if (me_arg
->attr
.allocatable
)
12553 gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
12554 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12555 me_arg
->name
, &c
->loc
);
12560 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12561 gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
12562 " at %L", c
->name
, &c
->loc
);
12566 /* Check type-spec if this is not the parent-type component. */
12567 if (((sym
->attr
.is_class
12568 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12569 || c
!= sym
->components
->ts
.u
.derived
->components
))
12570 || (!sym
->attr
.is_class
12571 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12572 && !sym
->attr
.vtype
12573 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12576 /* If this type is an extension, set the accessibility of the parent
12579 && ((sym
->attr
.is_class
12580 && c
== sym
->components
->ts
.u
.derived
->components
)
12581 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12582 && strcmp (super_type
->name
, c
->name
) == 0)
12583 c
->attr
.access
= super_type
->attr
.access
;
12585 /* If this type is an extension, see if this component has the same name
12586 as an inherited type-bound procedure. */
12587 if (super_type
&& !sym
->attr
.is_class
12588 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12590 gfc_error ("Component %qs of %qs at %L has the same name as an"
12591 " inherited type-bound procedure",
12592 c
->name
, sym
->name
, &c
->loc
);
12596 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12597 && !c
->ts
.deferred
)
12599 if (c
->ts
.u
.cl
->length
== NULL
12600 || (!resolve_charlen(c
->ts
.u
.cl
))
12601 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12603 gfc_error ("Character length of component %qs needs to "
12604 "be a constant specification expression at %L",
12606 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12611 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12612 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12614 gfc_error ("Character component %qs of %qs at %L with deferred "
12615 "length must be a POINTER or ALLOCATABLE",
12616 c
->name
, sym
->name
, &c
->loc
);
12620 /* Add the hidden deferred length field. */
12621 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
12622 && !sym
->attr
.is_class
)
12624 char name
[GFC_MAX_SYMBOL_LEN
+9];
12625 gfc_component
*strlen
;
12626 sprintf (name
, "_%s_length", c
->name
);
12627 strlen
= gfc_find_component (sym
, name
, true, true);
12628 if (strlen
== NULL
)
12630 if (!gfc_add_component (sym
, name
, &strlen
))
12632 strlen
->ts
.type
= BT_INTEGER
;
12633 strlen
->ts
.kind
= gfc_charlen_int_kind
;
12634 strlen
->attr
.access
= ACCESS_PRIVATE
;
12635 strlen
->attr
.deferred_parameter
= 1;
12639 if (c
->ts
.type
== BT_DERIVED
12640 && sym
->component_access
!= ACCESS_PRIVATE
12641 && gfc_check_symbol_access (sym
)
12642 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12643 && !c
->ts
.u
.derived
->attr
.use_assoc
12644 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12645 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12646 "PRIVATE type and cannot be a component of "
12647 "'%s', which is PUBLIC at %L", c
->name
,
12648 sym
->name
, &sym
->declared_at
))
12651 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12653 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12654 "type %s", c
->name
, &c
->loc
, sym
->name
);
12658 if (sym
->attr
.sequence
)
12660 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12662 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12663 "not have the SEQUENCE attribute",
12664 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12669 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12670 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12671 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12672 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12673 CLASS_DATA (c
)->ts
.u
.derived
12674 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12676 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12677 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12678 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12680 gfc_error ("The pointer component %qs of %qs at %L is a type "
12681 "that has not been declared", c
->name
, sym
->name
,
12686 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12687 && CLASS_DATA (c
)->attr
.class_pointer
12688 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12689 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12690 && !UNLIMITED_POLY (c
))
12692 gfc_error ("The pointer component %qs of %qs at %L is a type "
12693 "that has not been declared", c
->name
, sym
->name
,
12699 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12700 && (!c
->attr
.class_ok
12701 || !(CLASS_DATA (c
)->attr
.class_pointer
12702 || CLASS_DATA (c
)->attr
.allocatable
)))
12704 gfc_error ("Component %qs with CLASS at %L must be allocatable "
12705 "or pointer", c
->name
, &c
->loc
);
12706 /* Prevent a recurrence of the error. */
12707 c
->ts
.type
= BT_UNKNOWN
;
12711 /* Ensure that all the derived type components are put on the
12712 derived type list; even in formal namespaces, where derived type
12713 pointer components might not have been declared. */
12714 if (c
->ts
.type
== BT_DERIVED
12716 && c
->ts
.u
.derived
->components
12718 && sym
!= c
->ts
.u
.derived
)
12719 add_dt_to_dt_list (c
->ts
.u
.derived
);
12721 if (!gfc_resolve_array_spec (c
->as
,
12722 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12723 || c
->attr
.allocatable
)))
12726 if (c
->initializer
&& !sym
->attr
.vtype
12727 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12731 check_defined_assignments (sym
);
12733 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12734 sym
->attr
.defined_assign_comp
12735 = super_type
->attr
.defined_assign_comp
;
12737 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12738 all DEFERRED bindings are overridden. */
12739 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12740 && !sym
->attr
.is_class
12741 && !ensure_not_abstract (sym
, super_type
))
12744 /* Add derived type to the derived type list. */
12745 add_dt_to_dt_list (sym
);
12751 /* The following procedure does the full resolution of a derived type,
12752 including resolution of all type-bound procedures (if present). In contrast
12753 to 'resolve_fl_derived0' this can only be done after the module has been
12754 parsed completely. */
12757 resolve_fl_derived (gfc_symbol
*sym
)
12759 gfc_symbol
*gen_dt
= NULL
;
12761 if (sym
->attr
.unlimited_polymorphic
)
12764 if (!sym
->attr
.is_class
)
12765 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12766 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12767 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12768 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12769 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12770 "'%s' at %L being the same name as derived "
12771 "type at %L", sym
->name
,
12772 gen_dt
->generic
->sym
== sym
12773 ? gen_dt
->generic
->next
->sym
->name
12774 : gen_dt
->generic
->sym
->name
,
12775 gen_dt
->generic
->sym
== sym
12776 ? &gen_dt
->generic
->next
->sym
->declared_at
12777 : &gen_dt
->generic
->sym
->declared_at
,
12778 &sym
->declared_at
))
12781 /* Resolve the finalizer procedures. */
12782 if (!gfc_resolve_finalizers (sym
, NULL
))
12785 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12787 /* Fix up incomplete CLASS symbols. */
12788 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12789 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12791 /* Nothing more to do for unlimited polymorphic entities. */
12792 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12794 else if (vptr
->ts
.u
.derived
== NULL
)
12796 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12798 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12802 if (!resolve_fl_derived0 (sym
))
12805 /* Resolve the type-bound procedures. */
12806 if (!resolve_typebound_procedures (sym
))
12814 resolve_fl_namelist (gfc_symbol
*sym
)
12819 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12821 /* Check again, the check in match only works if NAMELIST comes
12823 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12825 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12826 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12830 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12831 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12832 "with assumed shape in namelist '%s' at %L",
12833 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12836 if (is_non_constant_shape_array (nl
->sym
)
12837 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12838 "with nonconstant shape in namelist '%s' at %L",
12839 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12842 if (nl
->sym
->ts
.type
== BT_CHARACTER
12843 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12844 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12845 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12846 "nonconstant character length in "
12847 "namelist '%s' at %L", nl
->sym
->name
,
12848 sym
->name
, &sym
->declared_at
))
12851 /* FIXME: Once UDDTIO is implemented, the following can be
12853 if (nl
->sym
->ts
.type
== BT_CLASS
)
12855 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12856 "polymorphic and requires a defined input/output "
12857 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12861 if (nl
->sym
->ts
.type
== BT_DERIVED
12862 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12863 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12865 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12866 "namelist '%s' at %L with ALLOCATABLE "
12867 "or POINTER components", nl
->sym
->name
,
12868 sym
->name
, &sym
->declared_at
))
12871 /* FIXME: Once UDDTIO is implemented, the following can be
12873 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12874 "ALLOCATABLE or POINTER components and thus requires "
12875 "a defined input/output procedure", nl
->sym
->name
,
12876 sym
->name
, &sym
->declared_at
);
12881 /* Reject PRIVATE objects in a PUBLIC namelist. */
12882 if (gfc_check_symbol_access (sym
))
12884 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12886 if (!nl
->sym
->attr
.use_assoc
12887 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12888 && !gfc_check_symbol_access (nl
->sym
))
12890 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12891 "cannot be member of PUBLIC namelist '%s' at %L",
12892 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12896 /* Types with private components that came here by USE-association. */
12897 if (nl
->sym
->ts
.type
== BT_DERIVED
12898 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12900 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12901 "components and cannot be member of namelist '%s' at %L",
12902 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12906 /* Types with private components that are defined in the same module. */
12907 if (nl
->sym
->ts
.type
== BT_DERIVED
12908 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12909 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12911 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12912 "cannot be a member of PUBLIC namelist '%s' at %L",
12913 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12920 /* 14.1.2 A module or internal procedure represent local entities
12921 of the same type as a namelist member and so are not allowed. */
12922 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12924 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12927 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12928 if ((nl
->sym
== sym
->ns
->proc_name
)
12930 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12935 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12936 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12938 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12939 "attribute in '%s' at %L", nlsym
->name
,
12940 &sym
->declared_at
);
12950 resolve_fl_parameter (gfc_symbol
*sym
)
12952 /* A parameter array's shape needs to be constant. */
12953 if (sym
->as
!= NULL
12954 && (sym
->as
->type
== AS_DEFERRED
12955 || is_non_constant_shape_array (sym
)))
12957 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12958 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12962 /* Make sure a parameter that has been implicitly typed still
12963 matches the implicit type, since PARAMETER statements can precede
12964 IMPLICIT statements. */
12965 if (sym
->attr
.implicit_type
12966 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12969 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12970 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12974 /* Make sure the types of derived parameters are consistent. This
12975 type checking is deferred until resolution because the type may
12976 refer to a derived type from the host. */
12977 if (sym
->ts
.type
== BT_DERIVED
12978 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12980 gfc_error ("Incompatible derived type in PARAMETER at %L",
12981 &sym
->value
->where
);
12988 /* Do anything necessary to resolve a symbol. Right now, we just
12989 assume that an otherwise unknown symbol is a variable. This sort
12990 of thing commonly happens for symbols in module. */
12993 resolve_symbol (gfc_symbol
*sym
)
12995 int check_constant
, mp_flag
;
12996 gfc_symtree
*symtree
;
12997 gfc_symtree
*this_symtree
;
13000 symbol_attribute class_attr
;
13001 gfc_array_spec
*as
;
13002 bool saved_specification_expr
;
13008 if (sym
->attr
.artificial
)
13011 if (sym
->attr
.unlimited_polymorphic
)
13014 if (sym
->attr
.flavor
== FL_UNKNOWN
13015 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13016 && !sym
->attr
.generic
&& !sym
->attr
.external
13017 && sym
->attr
.if_source
== IFSRC_UNKNOWN
13018 && sym
->ts
.type
== BT_UNKNOWN
))
13021 /* If we find that a flavorless symbol is an interface in one of the
13022 parent namespaces, find its symtree in this namespace, free the
13023 symbol and set the symtree to point to the interface symbol. */
13024 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13026 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13027 if (symtree
&& (symtree
->n
.sym
->generic
||
13028 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13029 && sym
->ns
->construct_entities
)))
13031 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13033 gfc_release_symbol (sym
);
13034 symtree
->n
.sym
->refs
++;
13035 this_symtree
->n
.sym
= symtree
->n
.sym
;
13040 /* Otherwise give it a flavor according to such attributes as
13042 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13043 && sym
->attr
.intrinsic
== 0)
13044 sym
->attr
.flavor
= FL_VARIABLE
;
13045 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13047 sym
->attr
.flavor
= FL_PROCEDURE
;
13048 if (sym
->attr
.dimension
)
13049 sym
->attr
.function
= 1;
13053 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13054 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13056 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13057 && !resolve_procedure_interface (sym
))
13060 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13061 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13063 if (sym
->attr
.external
)
13064 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13065 "at %L", &sym
->declared_at
);
13067 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13068 "at %L", &sym
->declared_at
);
13073 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
13076 /* Symbols that are module procedures with results (functions) have
13077 the types and array specification copied for type checking in
13078 procedures that call them, as well as for saving to a module
13079 file. These symbols can't stand the scrutiny that their results
13081 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13083 /* Make sure that the intrinsic is consistent with its internal
13084 representation. This needs to be done before assigning a default
13085 type to avoid spurious warnings. */
13086 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13087 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
13090 /* Resolve associate names. */
13092 resolve_assoc_var (sym
, true);
13094 /* Assign default type to symbols that need one and don't have one. */
13095 if (sym
->ts
.type
== BT_UNKNOWN
)
13097 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13099 gfc_set_default_type (sym
, 1, NULL
);
13102 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13103 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13104 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13105 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13107 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13109 /* The specific case of an external procedure should emit an error
13110 in the case that there is no implicit type. */
13112 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13115 /* Result may be in another namespace. */
13116 resolve_symbol (sym
->result
);
13118 if (!sym
->result
->attr
.proc_pointer
)
13120 sym
->ts
= sym
->result
->ts
;
13121 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13122 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13123 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13124 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13125 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13130 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13132 bool saved_specification_expr
= specification_expr
;
13133 specification_expr
= true;
13134 gfc_resolve_array_spec (sym
->result
->as
, false);
13135 specification_expr
= saved_specification_expr
;
13138 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13140 as
= CLASS_DATA (sym
)->as
;
13141 class_attr
= CLASS_DATA (sym
)->attr
;
13142 class_attr
.pointer
= class_attr
.class_pointer
;
13146 class_attr
= sym
->attr
;
13151 if (sym
->attr
.contiguous
13152 && (!class_attr
.dimension
13153 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13154 && !class_attr
.pointer
)))
13156 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
13157 "array pointer or an assumed-shape or assumed-rank array",
13158 sym
->name
, &sym
->declared_at
);
13162 /* Assumed size arrays and assumed shape arrays must be dummy
13163 arguments. Array-spec's of implied-shape should have been resolved to
13164 AS_EXPLICIT already. */
13168 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13169 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13170 || as
->type
== AS_ASSUMED_SHAPE
)
13171 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13173 if (as
->type
== AS_ASSUMED_SIZE
)
13174 gfc_error ("Assumed size array at %L must be a dummy argument",
13175 &sym
->declared_at
);
13177 gfc_error ("Assumed shape array at %L must be a dummy argument",
13178 &sym
->declared_at
);
13181 /* TS 29113, C535a. */
13182 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13183 && !sym
->attr
.select_type_temporary
)
13185 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13186 &sym
->declared_at
);
13189 if (as
->type
== AS_ASSUMED_RANK
13190 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13192 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13193 "CODIMENSION attribute", &sym
->declared_at
);
13198 /* Make sure symbols with known intent or optional are really dummy
13199 variable. Because of ENTRY statement, this has to be deferred
13200 until resolution time. */
13202 if (!sym
->attr
.dummy
13203 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13205 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13209 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13211 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
13212 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13216 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13218 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13219 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13221 gfc_error ("Character dummy variable '%s' at %L with VALUE "
13222 "attribute must have constant length",
13223 sym
->name
, &sym
->declared_at
);
13227 if (sym
->ts
.is_c_interop
13228 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13230 gfc_error ("C interoperable character dummy variable '%s' at %L "
13231 "with VALUE attribute must have length one",
13232 sym
->name
, &sym
->declared_at
);
13237 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13238 && sym
->ts
.u
.derived
->attr
.generic
)
13240 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13241 if (!sym
->ts
.u
.derived
)
13243 gfc_error ("The derived type '%s' at %L is of type '%s', "
13244 "which has not been defined", sym
->name
,
13245 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13246 sym
->ts
.type
= BT_UNKNOWN
;
13251 /* Use the same constraints as TYPE(*), except for the type check
13252 and that only scalars and assumed-size arrays are permitted. */
13253 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
13255 if (!sym
->attr
.dummy
)
13257 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13258 "a dummy argument", sym
->name
, &sym
->declared_at
);
13262 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
13263 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
13264 && sym
->ts
.type
!= BT_COMPLEX
)
13266 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
13267 "of type TYPE(*) or of an numeric intrinsic type",
13268 sym
->name
, &sym
->declared_at
);
13272 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13273 || sym
->attr
.pointer
|| sym
->attr
.value
)
13275 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13276 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
13277 "attribute", sym
->name
, &sym
->declared_at
);
13281 if (sym
->attr
.intent
== INTENT_OUT
)
13283 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
13284 "have the INTENT(OUT) attribute",
13285 sym
->name
, &sym
->declared_at
);
13288 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
13290 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
13291 "either be a scalar or an assumed-size array",
13292 sym
->name
, &sym
->declared_at
);
13296 /* Set the type to TYPE(*) and add a dimension(*) to ensure
13297 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
13299 sym
->ts
.type
= BT_ASSUMED
;
13300 sym
->as
= gfc_get_array_spec ();
13301 sym
->as
->type
= AS_ASSUMED_SIZE
;
13303 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
13305 else if (sym
->ts
.type
== BT_ASSUMED
)
13307 /* TS 29113, C407a. */
13308 if (!sym
->attr
.dummy
)
13310 gfc_error ("Assumed type of variable %s at %L is only permitted "
13311 "for dummy variables", sym
->name
, &sym
->declared_at
);
13314 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13315 || sym
->attr
.pointer
|| sym
->attr
.value
)
13317 gfc_error ("Assumed-type variable %s at %L may not have the "
13318 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13319 sym
->name
, &sym
->declared_at
);
13322 if (sym
->attr
.intent
== INTENT_OUT
)
13324 gfc_error ("Assumed-type variable %s at %L may not have the "
13325 "INTENT(OUT) attribute",
13326 sym
->name
, &sym
->declared_at
);
13329 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13331 gfc_error ("Assumed-type variable %s at %L shall not be an "
13332 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13337 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13338 do this for something that was implicitly typed because that is handled
13339 in gfc_set_default_type. Handle dummy arguments and procedure
13340 definitions separately. Also, anything that is use associated is not
13341 handled here but instead is handled in the module it is declared in.
13342 Finally, derived type definitions are allowed to be BIND(C) since that
13343 only implies that they're interoperable, and they are checked fully for
13344 interoperability when a variable is declared of that type. */
13345 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13346 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13347 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13351 /* First, make sure the variable is declared at the
13352 module-level scope (J3/04-007, Section 15.3). */
13353 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13354 sym
->attr
.in_common
== 0)
13356 gfc_error ("Variable %qs at %L cannot be BIND(C) because it "
13357 "is neither a COMMON block nor declared at the "
13358 "module level scope", sym
->name
, &(sym
->declared_at
));
13361 else if (sym
->common_head
!= NULL
)
13363 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13367 /* If type() declaration, we need to verify that the components
13368 of the given type are all C interoperable, etc. */
13369 if (sym
->ts
.type
== BT_DERIVED
&&
13370 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13372 /* Make sure the user marked the derived type as BIND(C). If
13373 not, call the verify routine. This could print an error
13374 for the derived type more than once if multiple variables
13375 of that type are declared. */
13376 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13377 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13381 /* Verify the variable itself as C interoperable if it
13382 is BIND(C). It is not possible for this to succeed if
13383 the verify_bind_c_derived_type failed, so don't have to handle
13384 any error returned by verify_bind_c_derived_type. */
13385 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13386 sym
->common_block
);
13391 /* clear the is_bind_c flag to prevent reporting errors more than
13392 once if something failed. */
13393 sym
->attr
.is_bind_c
= 0;
13398 /* If a derived type symbol has reached this point, without its
13399 type being declared, we have an error. Notice that most
13400 conditions that produce undefined derived types have already
13401 been dealt with. However, the likes of:
13402 implicit type(t) (t) ..... call foo (t) will get us here if
13403 the type is not declared in the scope of the implicit
13404 statement. Change the type to BT_UNKNOWN, both because it is so
13405 and to prevent an ICE. */
13406 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13407 && sym
->ts
.u
.derived
->components
== NULL
13408 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13410 gfc_error ("The derived type '%s' at %L is of type '%s', "
13411 "which has not been defined", sym
->name
,
13412 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13413 sym
->ts
.type
= BT_UNKNOWN
;
13417 /* Make sure that the derived type has been resolved and that the
13418 derived type is visible in the symbol's namespace, if it is a
13419 module function and is not PRIVATE. */
13420 if (sym
->ts
.type
== BT_DERIVED
13421 && sym
->ts
.u
.derived
->attr
.use_assoc
13422 && sym
->ns
->proc_name
13423 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13424 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13427 /* Unless the derived-type declaration is use associated, Fortran 95
13428 does not allow public entries of private derived types.
13429 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13430 161 in 95-006r3. */
13431 if (sym
->ts
.type
== BT_DERIVED
13432 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13433 && !sym
->ts
.u
.derived
->attr
.use_assoc
13434 && gfc_check_symbol_access (sym
)
13435 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13436 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13437 "derived type '%s'",
13438 (sym
->attr
.flavor
== FL_PARAMETER
)
13439 ? "parameter" : "variable",
13440 sym
->name
, &sym
->declared_at
,
13441 sym
->ts
.u
.derived
->name
))
13444 /* F2008, C1302. */
13445 if (sym
->ts
.type
== BT_DERIVED
13446 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13447 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13448 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13449 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13451 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13452 "type LOCK_TYPE must be a coarray", sym
->name
,
13453 &sym
->declared_at
);
13457 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13458 default initialization is defined (5.1.2.4.4). */
13459 if (sym
->ts
.type
== BT_DERIVED
13461 && sym
->attr
.intent
== INTENT_OUT
13463 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13465 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13467 if (c
->initializer
)
13469 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13470 "ASSUMED SIZE and so cannot have a default initializer",
13471 sym
->name
, &sym
->declared_at
);
13478 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13479 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13481 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13482 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13487 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13488 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13489 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13490 || class_attr
.codimension
)
13491 && (sym
->attr
.result
|| sym
->result
== sym
))
13493 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13494 "a coarray component", sym
->name
, &sym
->declared_at
);
13499 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13500 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13502 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13503 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13508 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13509 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13510 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13511 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13512 || class_attr
.allocatable
))
13514 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13515 "nonpointer, nonallocatable scalar, which is not a coarray",
13516 sym
->name
, &sym
->declared_at
);
13520 /* F2008, C526. The function-result case was handled above. */
13521 if (class_attr
.codimension
13522 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13523 || sym
->attr
.select_type_temporary
13524 || sym
->ns
->save_all
13525 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13526 || sym
->ns
->proc_name
->attr
.is_main_program
13527 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13529 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13530 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13534 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13535 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13537 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13538 "deferred shape", sym
->name
, &sym
->declared_at
);
13541 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13542 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13544 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13545 "deferred shape", sym
->name
, &sym
->declared_at
);
13550 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13551 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13552 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13553 || (class_attr
.codimension
&& class_attr
.allocatable
))
13554 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13556 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13557 "allocatable coarray or have coarray components",
13558 sym
->name
, &sym
->declared_at
);
13562 if (class_attr
.codimension
&& sym
->attr
.dummy
13563 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13565 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13566 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13567 sym
->ns
->proc_name
->name
);
13571 if (sym
->ts
.type
== BT_LOGICAL
13572 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13573 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13574 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13577 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13578 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13580 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13581 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13582 "%L with non-C_Bool kind in BIND(C) procedure "
13583 "'%s'", sym
->name
, &sym
->declared_at
,
13584 sym
->ns
->proc_name
->name
))
13586 else if (!gfc_logical_kinds
[i
].c_bool
13587 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13588 "'%s' at %L with non-C_Bool kind in "
13589 "BIND(C) procedure '%s'", sym
->name
,
13591 sym
->attr
.function
? sym
->name
13592 : sym
->ns
->proc_name
->name
))
13596 switch (sym
->attr
.flavor
)
13599 if (!resolve_fl_variable (sym
, mp_flag
))
13604 if (!resolve_fl_procedure (sym
, mp_flag
))
13609 if (!resolve_fl_namelist (sym
))
13614 if (!resolve_fl_parameter (sym
))
13622 /* Resolve array specifier. Check as well some constraints
13623 on COMMON blocks. */
13625 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13627 /* Set the formal_arg_flag so that check_conflict will not throw
13628 an error for host associated variables in the specification
13629 expression for an array_valued function. */
13630 if (sym
->attr
.function
&& sym
->as
)
13631 formal_arg_flag
= 1;
13633 saved_specification_expr
= specification_expr
;
13634 specification_expr
= true;
13635 gfc_resolve_array_spec (sym
->as
, check_constant
);
13636 specification_expr
= saved_specification_expr
;
13638 formal_arg_flag
= 0;
13640 /* Resolve formal namespaces. */
13641 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13642 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13643 gfc_resolve (sym
->formal_ns
);
13645 /* Make sure the formal namespace is present. */
13646 if (sym
->formal
&& !sym
->formal_ns
)
13648 gfc_formal_arglist
*formal
= sym
->formal
;
13649 while (formal
&& !formal
->sym
)
13650 formal
= formal
->next
;
13654 sym
->formal_ns
= formal
->sym
->ns
;
13655 if (sym
->ns
!= formal
->sym
->ns
)
13656 sym
->formal_ns
->refs
++;
13660 /* Check threadprivate restrictions. */
13661 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13662 && (!sym
->attr
.in_common
13663 && sym
->module
== NULL
13664 && (sym
->ns
->proc_name
== NULL
13665 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13666 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13668 /* Check omp declare target restrictions. */
13669 if (sym
->attr
.omp_declare_target
13670 && sym
->attr
.flavor
== FL_VARIABLE
13672 && !sym
->ns
->save_all
13673 && (!sym
->attr
.in_common
13674 && sym
->module
== NULL
13675 && (sym
->ns
->proc_name
== NULL
13676 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13677 gfc_error ("!$OMP DECLARE TARGET variable '%s' at %L isn't SAVEd",
13678 sym
->name
, &sym
->declared_at
);
13680 /* If we have come this far we can apply default-initializers, as
13681 described in 14.7.5, to those variables that have not already
13682 been assigned one. */
13683 if (sym
->ts
.type
== BT_DERIVED
13685 && !sym
->attr
.allocatable
13686 && !sym
->attr
.alloc_comp
)
13688 symbol_attribute
*a
= &sym
->attr
;
13690 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13691 && !a
->in_common
&& !a
->use_assoc
13692 && (a
->referenced
|| a
->result
)
13693 && !(a
->function
&& sym
!= sym
->result
))
13694 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13695 apply_default_init (sym
);
13698 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13699 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13700 && !CLASS_DATA (sym
)->attr
.class_pointer
13701 && !CLASS_DATA (sym
)->attr
.allocatable
)
13702 apply_default_init (sym
);
13704 /* If this symbol has a type-spec, check it. */
13705 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13706 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13707 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13712 /************* Resolve DATA statements *************/
13716 gfc_data_value
*vnode
;
13722 /* Advance the values structure to point to the next value in the data list. */
13725 next_data_value (void)
13727 while (mpz_cmp_ui (values
.left
, 0) == 0)
13730 if (values
.vnode
->next
== NULL
)
13733 values
.vnode
= values
.vnode
->next
;
13734 mpz_set (values
.left
, values
.vnode
->repeat
);
13742 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13748 ar_type mark
= AR_UNKNOWN
;
13750 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13756 if (!gfc_resolve_expr (var
->expr
))
13760 mpz_init_set_si (offset
, 0);
13763 if (e
->expr_type
!= EXPR_VARIABLE
)
13764 gfc_internal_error ("check_data_variable(): Bad expression");
13766 sym
= e
->symtree
->n
.sym
;
13768 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13770 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13771 sym
->name
, &sym
->declared_at
);
13774 if (e
->ref
== NULL
&& sym
->as
)
13776 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13777 " declaration", sym
->name
, where
);
13781 has_pointer
= sym
->attr
.pointer
;
13783 if (gfc_is_coindexed (e
))
13785 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13790 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13792 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13796 && ref
->type
== REF_ARRAY
13797 && ref
->u
.ar
.type
!= AR_FULL
)
13799 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13800 "be a full array", sym
->name
, where
);
13805 if (e
->rank
== 0 || has_pointer
)
13807 mpz_init_set_ui (size
, 1);
13814 /* Find the array section reference. */
13815 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13817 if (ref
->type
!= REF_ARRAY
)
13819 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13825 /* Set marks according to the reference pattern. */
13826 switch (ref
->u
.ar
.type
)
13834 /* Get the start position of array section. */
13835 gfc_get_section_index (ar
, section_index
, &offset
);
13840 gcc_unreachable ();
13843 if (!gfc_array_size (e
, &size
))
13845 gfc_error ("Nonconstant array section at %L in DATA statement",
13847 mpz_clear (offset
);
13854 while (mpz_cmp_ui (size
, 0) > 0)
13856 if (!next_data_value ())
13858 gfc_error ("DATA statement at %L has more variables than values",
13864 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13868 /* If we have more than one element left in the repeat count,
13869 and we have more than one element left in the target variable,
13870 then create a range assignment. */
13871 /* FIXME: Only done for full arrays for now, since array sections
13873 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13874 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13878 if (mpz_cmp (size
, values
.left
) >= 0)
13880 mpz_init_set (range
, values
.left
);
13881 mpz_sub (size
, size
, values
.left
);
13882 mpz_set_ui (values
.left
, 0);
13886 mpz_init_set (range
, size
);
13887 mpz_sub (values
.left
, values
.left
, size
);
13888 mpz_set_ui (size
, 0);
13891 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13894 mpz_add (offset
, offset
, range
);
13901 /* Assign initial value to symbol. */
13904 mpz_sub_ui (values
.left
, values
.left
, 1);
13905 mpz_sub_ui (size
, size
, 1);
13907 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13912 if (mark
== AR_FULL
)
13913 mpz_add_ui (offset
, offset
, 1);
13915 /* Modify the array section indexes and recalculate the offset
13916 for next element. */
13917 else if (mark
== AR_SECTION
)
13918 gfc_advance_section (section_index
, ar
, &offset
);
13922 if (mark
== AR_SECTION
)
13924 for (i
= 0; i
< ar
->dimen
; i
++)
13925 mpz_clear (section_index
[i
]);
13929 mpz_clear (offset
);
13935 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13937 /* Iterate over a list of elements in a DATA statement. */
13940 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13943 iterator_stack frame
;
13944 gfc_expr
*e
, *start
, *end
, *step
;
13945 bool retval
= true;
13947 mpz_init (frame
.value
);
13950 start
= gfc_copy_expr (var
->iter
.start
);
13951 end
= gfc_copy_expr (var
->iter
.end
);
13952 step
= gfc_copy_expr (var
->iter
.step
);
13954 if (!gfc_simplify_expr (start
, 1)
13955 || start
->expr_type
!= EXPR_CONSTANT
)
13957 gfc_error ("start of implied-do loop at %L could not be "
13958 "simplified to a constant value", &start
->where
);
13962 if (!gfc_simplify_expr (end
, 1)
13963 || end
->expr_type
!= EXPR_CONSTANT
)
13965 gfc_error ("end of implied-do loop at %L could not be "
13966 "simplified to a constant value", &start
->where
);
13970 if (!gfc_simplify_expr (step
, 1)
13971 || step
->expr_type
!= EXPR_CONSTANT
)
13973 gfc_error ("step of implied-do loop at %L could not be "
13974 "simplified to a constant value", &start
->where
);
13979 mpz_set (trip
, end
->value
.integer
);
13980 mpz_sub (trip
, trip
, start
->value
.integer
);
13981 mpz_add (trip
, trip
, step
->value
.integer
);
13983 mpz_div (trip
, trip
, step
->value
.integer
);
13985 mpz_set (frame
.value
, start
->value
.integer
);
13987 frame
.prev
= iter_stack
;
13988 frame
.variable
= var
->iter
.var
->symtree
;
13989 iter_stack
= &frame
;
13991 while (mpz_cmp_ui (trip
, 0) > 0)
13993 if (!traverse_data_var (var
->list
, where
))
13999 e
= gfc_copy_expr (var
->expr
);
14000 if (!gfc_simplify_expr (e
, 1))
14007 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14009 mpz_sub_ui (trip
, trip
, 1);
14013 mpz_clear (frame
.value
);
14016 gfc_free_expr (start
);
14017 gfc_free_expr (end
);
14018 gfc_free_expr (step
);
14020 iter_stack
= frame
.prev
;
14025 /* Type resolve variables in the variable list of a DATA statement. */
14028 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14032 for (; var
; var
= var
->next
)
14034 if (var
->expr
== NULL
)
14035 t
= traverse_data_list (var
, where
);
14037 t
= check_data_variable (var
, where
);
14047 /* Resolve the expressions and iterators associated with a data statement.
14048 This is separate from the assignment checking because data lists should
14049 only be resolved once. */
14052 resolve_data_variables (gfc_data_variable
*d
)
14054 for (; d
; d
= d
->next
)
14056 if (d
->list
== NULL
)
14058 if (!gfc_resolve_expr (d
->expr
))
14063 if (!gfc_resolve_iterator (&d
->iter
, false, true))
14066 if (!resolve_data_variables (d
->list
))
14075 /* Resolve a single DATA statement. We implement this by storing a pointer to
14076 the value list into static variables, and then recursively traversing the
14077 variables list, expanding iterators and such. */
14080 resolve_data (gfc_data
*d
)
14083 if (!resolve_data_variables (d
->var
))
14086 values
.vnode
= d
->value
;
14087 if (d
->value
== NULL
)
14088 mpz_set_ui (values
.left
, 0);
14090 mpz_set (values
.left
, d
->value
->repeat
);
14092 if (!traverse_data_var (d
->var
, &d
->where
))
14095 /* At this point, we better not have any values left. */
14097 if (next_data_value ())
14098 gfc_error ("DATA statement at %L has more values than variables",
14103 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14104 accessed by host or use association, is a dummy argument to a pure function,
14105 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14106 is storage associated with any such variable, shall not be used in the
14107 following contexts: (clients of this function). */
14109 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14110 procedure. Returns zero if assignment is OK, nonzero if there is a
14113 gfc_impure_variable (gfc_symbol
*sym
)
14118 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14121 /* Check if the symbol's ns is inside the pure procedure. */
14122 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14126 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14130 proc
= sym
->ns
->proc_name
;
14131 if (sym
->attr
.dummy
14132 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14133 || proc
->attr
.function
))
14136 /* TODO: Sort out what can be storage associated, if anything, and include
14137 it here. In principle equivalences should be scanned but it does not
14138 seem to be possible to storage associate an impure variable this way. */
14143 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14144 current namespace is inside a pure procedure. */
14147 gfc_pure (gfc_symbol
*sym
)
14149 symbol_attribute attr
;
14154 /* Check if the current namespace or one of its parents
14155 belongs to a pure procedure. */
14156 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14158 sym
= ns
->proc_name
;
14162 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14170 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14174 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14175 checks if the current namespace is implicitly pure. Note that this
14176 function returns false for a PURE procedure. */
14179 gfc_implicit_pure (gfc_symbol
*sym
)
14185 /* Check if the current procedure is implicit_pure. Walk up
14186 the procedure list until we find a procedure. */
14187 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14189 sym
= ns
->proc_name
;
14193 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14198 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14199 && !sym
->attr
.pure
;
14204 gfc_unset_implicit_pure (gfc_symbol
*sym
)
14210 /* Check if the current procedure is implicit_pure. Walk up
14211 the procedure list until we find a procedure. */
14212 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14214 sym
= ns
->proc_name
;
14218 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14223 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14224 sym
->attr
.implicit_pure
= 0;
14226 sym
->attr
.pure
= 0;
14230 /* Test whether the current procedure is elemental or not. */
14233 gfc_elemental (gfc_symbol
*sym
)
14235 symbol_attribute attr
;
14238 sym
= gfc_current_ns
->proc_name
;
14243 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14247 /* Warn about unused labels. */
14250 warn_unused_fortran_label (gfc_st_label
*label
)
14255 warn_unused_fortran_label (label
->left
);
14257 if (label
->defined
== ST_LABEL_UNKNOWN
)
14260 switch (label
->referenced
)
14262 case ST_LABEL_UNKNOWN
:
14263 gfc_warning ("Label %d at %L defined but not used", label
->value
,
14267 case ST_LABEL_BAD_TARGET
:
14268 gfc_warning ("Label %d at %L defined but cannot be used",
14269 label
->value
, &label
->where
);
14276 warn_unused_fortran_label (label
->right
);
14280 /* Returns the sequence type of a symbol or sequence. */
14283 sequence_type (gfc_typespec ts
)
14292 if (ts
.u
.derived
->components
== NULL
)
14293 return SEQ_NONDEFAULT
;
14295 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14296 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14297 if (sequence_type (c
->ts
) != result
)
14303 if (ts
.kind
!= gfc_default_character_kind
)
14304 return SEQ_NONDEFAULT
;
14306 return SEQ_CHARACTER
;
14309 if (ts
.kind
!= gfc_default_integer_kind
)
14310 return SEQ_NONDEFAULT
;
14312 return SEQ_NUMERIC
;
14315 if (!(ts
.kind
== gfc_default_real_kind
14316 || ts
.kind
== gfc_default_double_kind
))
14317 return SEQ_NONDEFAULT
;
14319 return SEQ_NUMERIC
;
14322 if (ts
.kind
!= gfc_default_complex_kind
)
14323 return SEQ_NONDEFAULT
;
14325 return SEQ_NUMERIC
;
14328 if (ts
.kind
!= gfc_default_logical_kind
)
14329 return SEQ_NONDEFAULT
;
14331 return SEQ_NUMERIC
;
14334 return SEQ_NONDEFAULT
;
14339 /* Resolve derived type EQUIVALENCE object. */
14342 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14344 gfc_component
*c
= derived
->components
;
14349 /* Shall not be an object of nonsequence derived type. */
14350 if (!derived
->attr
.sequence
)
14352 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14353 "attribute to be an EQUIVALENCE object", sym
->name
,
14358 /* Shall not have allocatable components. */
14359 if (derived
->attr
.alloc_comp
)
14361 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14362 "components to be an EQUIVALENCE object",sym
->name
,
14367 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14369 gfc_error ("Derived type variable '%s' at %L with default "
14370 "initialization cannot be in EQUIVALENCE with a variable "
14371 "in COMMON", sym
->name
, &e
->where
);
14375 for (; c
; c
= c
->next
)
14377 if (c
->ts
.type
== BT_DERIVED
14378 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14381 /* Shall not be an object of sequence derived type containing a pointer
14382 in the structure. */
14383 if (c
->attr
.pointer
)
14385 gfc_error ("Derived type variable '%s' at %L with pointer "
14386 "component(s) cannot be an EQUIVALENCE object",
14387 sym
->name
, &e
->where
);
14395 /* Resolve equivalence object.
14396 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14397 an allocatable array, an object of nonsequence derived type, an object of
14398 sequence derived type containing a pointer at any level of component
14399 selection, an automatic object, a function name, an entry name, a result
14400 name, a named constant, a structure component, or a subobject of any of
14401 the preceding objects. A substring shall not have length zero. A
14402 derived type shall not have components with default initialization nor
14403 shall two objects of an equivalence group be initialized.
14404 Either all or none of the objects shall have an protected attribute.
14405 The simple constraints are done in symbol.c(check_conflict) and the rest
14406 are implemented here. */
14409 resolve_equivalence (gfc_equiv
*eq
)
14412 gfc_symbol
*first_sym
;
14415 locus
*last_where
= NULL
;
14416 seq_type eq_type
, last_eq_type
;
14417 gfc_typespec
*last_ts
;
14418 int object
, cnt_protected
;
14421 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14423 first_sym
= eq
->expr
->symtree
->n
.sym
;
14427 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14431 e
->ts
= e
->symtree
->n
.sym
->ts
;
14432 /* match_varspec might not know yet if it is seeing
14433 array reference or substring reference, as it doesn't
14435 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14437 gfc_ref
*ref
= e
->ref
;
14438 sym
= e
->symtree
->n
.sym
;
14440 if (sym
->attr
.dimension
)
14442 ref
->u
.ar
.as
= sym
->as
;
14446 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14447 if (e
->ts
.type
== BT_CHARACTER
14449 && ref
->type
== REF_ARRAY
14450 && ref
->u
.ar
.dimen
== 1
14451 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14452 && ref
->u
.ar
.stride
[0] == NULL
)
14454 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14455 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14458 /* Optimize away the (:) reference. */
14459 if (start
== NULL
&& end
== NULL
)
14462 e
->ref
= ref
->next
;
14464 e
->ref
->next
= ref
->next
;
14469 ref
->type
= REF_SUBSTRING
;
14471 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14473 ref
->u
.ss
.start
= start
;
14474 if (end
== NULL
&& e
->ts
.u
.cl
)
14475 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14476 ref
->u
.ss
.end
= end
;
14477 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14484 /* Any further ref is an error. */
14487 gcc_assert (ref
->type
== REF_ARRAY
);
14488 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14494 if (!gfc_resolve_expr (e
))
14497 sym
= e
->symtree
->n
.sym
;
14499 if (sym
->attr
.is_protected
)
14501 if (cnt_protected
> 0 && cnt_protected
!= object
)
14503 gfc_error ("Either all or none of the objects in the "
14504 "EQUIVALENCE set at %L shall have the "
14505 "PROTECTED attribute",
14510 /* Shall not equivalence common block variables in a PURE procedure. */
14511 if (sym
->ns
->proc_name
14512 && sym
->ns
->proc_name
->attr
.pure
14513 && sym
->attr
.in_common
)
14515 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14516 "object in the pure procedure '%s'",
14517 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14521 /* Shall not be a named constant. */
14522 if (e
->expr_type
== EXPR_CONSTANT
)
14524 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14525 "object", sym
->name
, &e
->where
);
14529 if (e
->ts
.type
== BT_DERIVED
14530 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14533 /* Check that the types correspond correctly:
14535 A numeric sequence structure may be equivalenced to another sequence
14536 structure, an object of default integer type, default real type, double
14537 precision real type, default logical type such that components of the
14538 structure ultimately only become associated to objects of the same
14539 kind. A character sequence structure may be equivalenced to an object
14540 of default character kind or another character sequence structure.
14541 Other objects may be equivalenced only to objects of the same type and
14542 kind parameters. */
14544 /* Identical types are unconditionally OK. */
14545 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14546 goto identical_types
;
14548 last_eq_type
= sequence_type (*last_ts
);
14549 eq_type
= sequence_type (sym
->ts
);
14551 /* Since the pair of objects is not of the same type, mixed or
14552 non-default sequences can be rejected. */
14554 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14555 "statement at %L with different type objects";
14557 && last_eq_type
== SEQ_MIXED
14558 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14559 || (eq_type
== SEQ_MIXED
14560 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14563 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14564 "statement at %L with objects of different type";
14566 && last_eq_type
== SEQ_NONDEFAULT
14567 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14568 || (eq_type
== SEQ_NONDEFAULT
14569 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14572 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14573 "EQUIVALENCE statement at %L";
14574 if (last_eq_type
== SEQ_CHARACTER
14575 && eq_type
!= SEQ_CHARACTER
14576 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14579 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14580 "EQUIVALENCE statement at %L";
14581 if (last_eq_type
== SEQ_NUMERIC
14582 && eq_type
!= SEQ_NUMERIC
14583 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14588 last_where
= &e
->where
;
14593 /* Shall not be an automatic array. */
14594 if (e
->ref
->type
== REF_ARRAY
14595 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14597 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14598 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14605 /* Shall not be a structure component. */
14606 if (r
->type
== REF_COMPONENT
)
14608 gfc_error ("Structure component '%s' at %L cannot be an "
14609 "EQUIVALENCE object",
14610 r
->u
.c
.component
->name
, &e
->where
);
14614 /* A substring shall not have length zero. */
14615 if (r
->type
== REF_SUBSTRING
)
14617 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14619 gfc_error ("Substring at %L has length zero",
14620 &r
->u
.ss
.start
->where
);
14630 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14633 resolve_fntype (gfc_namespace
*ns
)
14635 gfc_entry_list
*el
;
14638 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14641 /* If there are any entries, ns->proc_name is the entry master
14642 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14644 sym
= ns
->entries
->sym
;
14646 sym
= ns
->proc_name
;
14647 if (sym
->result
== sym
14648 && sym
->ts
.type
== BT_UNKNOWN
14649 && !gfc_set_default_type (sym
, 0, NULL
)
14650 && !sym
->attr
.untyped
)
14652 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14653 sym
->name
, &sym
->declared_at
);
14654 sym
->attr
.untyped
= 1;
14657 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14658 && !sym
->attr
.contained
14659 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14660 && gfc_check_symbol_access (sym
))
14662 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14663 "%L of PRIVATE type '%s'", sym
->name
,
14664 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14668 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14670 if (el
->sym
->result
== el
->sym
14671 && el
->sym
->ts
.type
== BT_UNKNOWN
14672 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14673 && !el
->sym
->attr
.untyped
)
14675 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14676 el
->sym
->name
, &el
->sym
->declared_at
);
14677 el
->sym
->attr
.untyped
= 1;
14683 /* 12.3.2.1.1 Defined operators. */
14686 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14688 gfc_formal_arglist
*formal
;
14690 if (!sym
->attr
.function
)
14692 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14693 sym
->name
, &where
);
14697 if (sym
->ts
.type
== BT_CHARACTER
14698 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14699 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14700 && sym
->result
->ts
.u
.cl
->length
))
14702 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14703 "character length", sym
->name
, &where
);
14707 formal
= gfc_sym_get_dummy_args (sym
);
14708 if (!formal
|| !formal
->sym
)
14710 gfc_error ("User operator procedure '%s' at %L must have at least "
14711 "one argument", sym
->name
, &where
);
14715 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14717 gfc_error ("First argument of operator interface at %L must be "
14718 "INTENT(IN)", &where
);
14722 if (formal
->sym
->attr
.optional
)
14724 gfc_error ("First argument of operator interface at %L cannot be "
14725 "optional", &where
);
14729 formal
= formal
->next
;
14730 if (!formal
|| !formal
->sym
)
14733 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14735 gfc_error ("Second argument of operator interface at %L must be "
14736 "INTENT(IN)", &where
);
14740 if (formal
->sym
->attr
.optional
)
14742 gfc_error ("Second argument of operator interface at %L cannot be "
14743 "optional", &where
);
14749 gfc_error ("Operator interface at %L must have, at most, two "
14750 "arguments", &where
);
14758 gfc_resolve_uops (gfc_symtree
*symtree
)
14760 gfc_interface
*itr
;
14762 if (symtree
== NULL
)
14765 gfc_resolve_uops (symtree
->left
);
14766 gfc_resolve_uops (symtree
->right
);
14768 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14769 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14773 /* Examine all of the expressions associated with a program unit,
14774 assign types to all intermediate expressions, make sure that all
14775 assignments are to compatible types and figure out which names
14776 refer to which functions or subroutines. It doesn't check code
14777 block, which is handled by gfc_resolve_code. */
14780 resolve_types (gfc_namespace
*ns
)
14786 gfc_namespace
* old_ns
= gfc_current_ns
;
14788 /* Check that all IMPLICIT types are ok. */
14789 if (!ns
->seen_implicit_none
)
14792 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14793 if (ns
->set_flag
[letter
]
14794 && !resolve_typespec_used (&ns
->default_type
[letter
],
14795 &ns
->implicit_loc
[letter
], NULL
))
14799 gfc_current_ns
= ns
;
14801 resolve_entries (ns
);
14803 resolve_common_vars (ns
->blank_common
.head
, false);
14804 resolve_common_blocks (ns
->common_root
);
14806 resolve_contained_functions (ns
);
14808 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14809 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14810 resolve_formal_arglist (ns
->proc_name
);
14812 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14814 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14815 resolve_charlen (cl
);
14817 gfc_traverse_ns (ns
, resolve_symbol
);
14819 resolve_fntype (ns
);
14821 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14823 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14824 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14825 "also be PURE", n
->proc_name
->name
,
14826 &n
->proc_name
->declared_at
);
14832 gfc_do_concurrent_flag
= 0;
14833 gfc_check_interfaces (ns
);
14835 gfc_traverse_ns (ns
, resolve_values
);
14841 for (d
= ns
->data
; d
; d
= d
->next
)
14845 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14847 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14849 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14850 resolve_equivalence (eq
);
14852 /* Warn about unused labels. */
14853 if (warn_unused_label
)
14854 warn_unused_fortran_label (ns
->st_labels
);
14856 gfc_resolve_uops (ns
->uop_root
);
14858 gfc_resolve_omp_declare_simd (ns
);
14860 gfc_resolve_omp_udrs (ns
->omp_udr_root
);
14862 gfc_current_ns
= old_ns
;
14866 /* Call gfc_resolve_code recursively. */
14869 resolve_codes (gfc_namespace
*ns
)
14872 bitmap_obstack old_obstack
;
14874 if (ns
->resolved
== 1)
14877 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14880 gfc_current_ns
= ns
;
14882 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14883 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14886 /* Set to an out of range value. */
14887 current_entry_id
= -1;
14889 old_obstack
= labels_obstack
;
14890 bitmap_obstack_initialize (&labels_obstack
);
14892 gfc_resolve_oacc_declare (ns
);
14893 gfc_resolve_code (ns
->code
, ns
);
14895 bitmap_obstack_release (&labels_obstack
);
14896 labels_obstack
= old_obstack
;
14900 /* This function is called after a complete program unit has been compiled.
14901 Its purpose is to examine all of the expressions associated with a program
14902 unit, assign types to all intermediate expressions, make sure that all
14903 assignments are to compatible types and figure out which names refer to
14904 which functions or subroutines. */
14907 gfc_resolve (gfc_namespace
*ns
)
14909 gfc_namespace
*old_ns
;
14910 code_stack
*old_cs_base
;
14916 old_ns
= gfc_current_ns
;
14917 old_cs_base
= cs_base
;
14919 resolve_types (ns
);
14920 component_assignment_level
= 0;
14921 resolve_codes (ns
);
14923 gfc_current_ns
= old_ns
;
14924 cs_base
= old_cs_base
;
14927 gfc_run_passes (ns
);