1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
32 #include "constructor.h"
34 /* Types used in equivalence statements. */
38 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
42 /* Stack to keep track of the nesting of blocks as we move through the
43 code. See resolve_branch() and resolve_code(). */
45 typedef struct code_stack
47 struct gfc_code
*head
, *current
;
48 struct code_stack
*prev
;
50 /* This bitmap keeps track of the targets valid for a branch from
51 inside this block except for END {IF|SELECT}s of enclosing
53 bitmap reachable_labels
;
57 static code_stack
*cs_base
= NULL
;
60 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
62 static int forall_flag
;
63 int gfc_do_concurrent_flag
;
65 /* True when we are resolving an expression that is an actual argument to
67 static bool actual_arg
= false;
68 /* True when we are resolving an expression that is the first actual argument
70 static bool first_actual_arg
= false;
73 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
75 static int omp_workshare_flag
;
77 /* Nonzero if we are processing a formal arglist. The corresponding function
78 resets the flag each time that it is read. */
79 static int formal_arg_flag
= 0;
81 /* True if we are resolving a specification expression. */
82 static bool specification_expr
= false;
84 /* The id of the last entry seen. */
85 static int current_entry_id
;
87 /* We use bitmaps to determine if a branch target is valid. */
88 static bitmap_obstack labels_obstack
;
90 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
91 static bool inquiry_argument
= false;
95 gfc_is_formal_arg (void)
97 return formal_arg_flag
;
100 /* Is the symbol host associated? */
102 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
104 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
113 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
114 an ABSTRACT derived-type. If where is not NULL, an error message with that
115 locus is printed, optionally using name. */
118 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
120 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
125 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
126 name
, where
, ts
->u
.derived
->name
);
128 gfc_error ("ABSTRACT type '%s' used at %L",
129 ts
->u
.derived
->name
, where
);
140 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
142 /* Several checks for F08:C1216. */
143 if (ifc
->attr
.procedure
)
145 gfc_error ("Interface '%s' at %L is declared "
146 "in a later PROCEDURE statement", ifc
->name
, where
);
151 /* For generic interfaces, check if there is
152 a specific procedure with the same name. */
153 gfc_interface
*gen
= ifc
->generic
;
154 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
158 gfc_error ("Interface '%s' at %L may not be generic",
163 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
165 gfc_error ("Interface '%s' at %L may not be a statement function",
169 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
170 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
171 ifc
->attr
.intrinsic
= 1;
172 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
174 gfc_error ("Intrinsic procedure '%s' not allowed in "
175 "PROCEDURE statement at %L", ifc
->name
, where
);
178 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
180 gfc_error ("Interface '%s' at %L must be explicit", ifc
->name
, where
);
187 static void resolve_symbol (gfc_symbol
*sym
);
190 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
193 resolve_procedure_interface (gfc_symbol
*sym
)
195 gfc_symbol
*ifc
= sym
->ts
.interface
;
202 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
203 sym
->name
, &sym
->declared_at
);
206 if (!check_proc_interface (ifc
, &sym
->declared_at
))
209 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
211 /* Resolve interface and copy attributes. */
212 resolve_symbol (ifc
);
213 if (ifc
->attr
.intrinsic
)
214 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
218 sym
->ts
= ifc
->result
->ts
;
223 sym
->ts
.interface
= ifc
;
224 sym
->attr
.function
= ifc
->attr
.function
;
225 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
227 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
228 sym
->attr
.pointer
= ifc
->attr
.pointer
;
229 sym
->attr
.pure
= ifc
->attr
.pure
;
230 sym
->attr
.elemental
= ifc
->attr
.elemental
;
231 sym
->attr
.dimension
= ifc
->attr
.dimension
;
232 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
233 sym
->attr
.recursive
= ifc
->attr
.recursive
;
234 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
235 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
236 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
237 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
238 /* Copy array spec. */
239 sym
->as
= gfc_copy_array_spec (ifc
->as
);
240 /* Copy char length. */
241 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
243 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
244 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
245 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
254 /* Resolve types of formal argument lists. These have to be done early so that
255 the formal argument lists of module procedures can be copied to the
256 containing module before the individual procedures are resolved
257 individually. We also resolve argument lists of procedures in interface
258 blocks because they are self-contained scoping units.
260 Since a dummy argument cannot be a non-dummy procedure, the only
261 resort left for untyped names are the IMPLICIT types. */
264 resolve_formal_arglist (gfc_symbol
*proc
)
266 gfc_formal_arglist
*f
;
268 bool saved_specification_expr
;
271 if (proc
->result
!= NULL
)
276 if (gfc_elemental (proc
)
277 || sym
->attr
.pointer
|| sym
->attr
.allocatable
278 || (sym
->as
&& sym
->as
->rank
!= 0))
280 proc
->attr
.always_explicit
= 1;
281 sym
->attr
.always_explicit
= 1;
286 for (f
= proc
->formal
; f
; f
= f
->next
)
294 /* Alternate return placeholder. */
295 if (gfc_elemental (proc
))
296 gfc_error ("Alternate return specifier in elemental subroutine "
297 "'%s' at %L is not allowed", proc
->name
,
299 if (proc
->attr
.function
)
300 gfc_error ("Alternate return specifier in function "
301 "'%s' at %L is not allowed", proc
->name
,
305 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
306 && !resolve_procedure_interface (sym
))
309 if (strcmp (proc
->name
, sym
->name
) == 0)
311 gfc_error ("Self-referential argument "
312 "'%s' at %L is not allowed", sym
->name
,
317 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
318 resolve_formal_arglist (sym
);
320 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
322 if (sym
->attr
.flavor
== FL_UNKNOWN
)
323 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
327 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
328 && (!sym
->attr
.function
|| sym
->result
== sym
))
329 gfc_set_default_type (sym
, 1, sym
->ns
);
332 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
333 ? CLASS_DATA (sym
)->as
: sym
->as
;
335 saved_specification_expr
= specification_expr
;
336 specification_expr
= true;
337 gfc_resolve_array_spec (as
, 0);
338 specification_expr
= saved_specification_expr
;
340 /* We can't tell if an array with dimension (:) is assumed or deferred
341 shape until we know if it has the pointer or allocatable attributes.
343 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
344 && ((sym
->ts
.type
!= BT_CLASS
345 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
346 || (sym
->ts
.type
== BT_CLASS
347 && !(CLASS_DATA (sym
)->attr
.class_pointer
348 || CLASS_DATA (sym
)->attr
.allocatable
)))
349 && sym
->attr
.flavor
!= FL_PROCEDURE
)
351 as
->type
= AS_ASSUMED_SHAPE
;
352 for (i
= 0; i
< as
->rank
; i
++)
353 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
356 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
357 || (as
&& as
->type
== AS_ASSUMED_RANK
)
358 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
359 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
360 && (CLASS_DATA (sym
)->attr
.class_pointer
361 || CLASS_DATA (sym
)->attr
.allocatable
362 || CLASS_DATA (sym
)->attr
.target
))
363 || sym
->attr
.optional
)
365 proc
->attr
.always_explicit
= 1;
367 proc
->result
->attr
.always_explicit
= 1;
370 /* If the flavor is unknown at this point, it has to be a variable.
371 A procedure specification would have already set the type. */
373 if (sym
->attr
.flavor
== FL_UNKNOWN
)
374 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
378 if (sym
->attr
.flavor
== FL_PROCEDURE
)
383 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
384 "also be PURE", sym
->name
, &sym
->declared_at
);
388 else if (!sym
->attr
.pointer
)
390 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
393 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
394 " of pure function '%s' at %L with VALUE "
395 "attribute but without INTENT(IN)",
396 sym
->name
, proc
->name
, &sym
->declared_at
);
398 gfc_error ("Argument '%s' of pure function '%s' at %L must "
399 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
403 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
406 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
407 " of pure subroutine '%s' at %L with VALUE "
408 "attribute but without INTENT", sym
->name
,
409 proc
->name
, &sym
->declared_at
);
411 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
412 "must have its INTENT specified or have the "
413 "VALUE attribute", sym
->name
, proc
->name
,
419 if (proc
->attr
.implicit_pure
)
421 if (sym
->attr
.flavor
== FL_PROCEDURE
)
424 proc
->attr
.implicit_pure
= 0;
426 else if (!sym
->attr
.pointer
)
428 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
430 proc
->attr
.implicit_pure
= 0;
432 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
434 proc
->attr
.implicit_pure
= 0;
438 if (gfc_elemental (proc
))
441 if (sym
->attr
.codimension
442 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
443 && CLASS_DATA (sym
)->attr
.codimension
))
445 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
446 "procedure", sym
->name
, &sym
->declared_at
);
450 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
451 && CLASS_DATA (sym
)->as
))
453 gfc_error ("Argument '%s' of elemental procedure at %L must "
454 "be scalar", sym
->name
, &sym
->declared_at
);
458 if (sym
->attr
.allocatable
459 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
460 && CLASS_DATA (sym
)->attr
.allocatable
))
462 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
463 "have the ALLOCATABLE attribute", sym
->name
,
468 if (sym
->attr
.pointer
469 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
470 && CLASS_DATA (sym
)->attr
.class_pointer
))
472 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
473 "have the POINTER attribute", sym
->name
,
478 if (sym
->attr
.flavor
== FL_PROCEDURE
)
480 gfc_error ("Dummy procedure '%s' not allowed in elemental "
481 "procedure '%s' at %L", sym
->name
, proc
->name
,
486 /* Fortran 2008 Corrigendum 1, C1290a. */
487 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
489 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
490 "have its INTENT specified or have the VALUE "
491 "attribute", sym
->name
, proc
->name
,
497 /* Each dummy shall be specified to be scalar. */
498 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
502 gfc_error ("Argument '%s' of statement function at %L must "
503 "be scalar", sym
->name
, &sym
->declared_at
);
507 if (sym
->ts
.type
== BT_CHARACTER
)
509 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
510 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
512 gfc_error ("Character-valued argument '%s' of statement "
513 "function at %L must have constant length",
514 sym
->name
, &sym
->declared_at
);
524 /* Work function called when searching for symbols that have argument lists
525 associated with them. */
528 find_arglists (gfc_symbol
*sym
)
530 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
531 || sym
->attr
.flavor
== FL_DERIVED
|| sym
->attr
.intrinsic
)
534 resolve_formal_arglist (sym
);
538 /* Given a namespace, resolve all formal argument lists within the namespace.
542 resolve_formal_arglists (gfc_namespace
*ns
)
547 gfc_traverse_ns (ns
, find_arglists
);
552 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
556 /* If this namespace is not a function or an entry master function,
558 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
559 || sym
->attr
.entry_master
)
562 /* Try to find out of what the return type is. */
563 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
565 t
= gfc_set_default_type (sym
->result
, 0, ns
);
567 if (!t
&& !sym
->result
->attr
.untyped
)
569 if (sym
->result
== sym
)
570 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
571 sym
->name
, &sym
->declared_at
);
572 else if (!sym
->result
->attr
.proc_pointer
)
573 gfc_error ("Result '%s' of contained function '%s' at %L has "
574 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
575 &sym
->result
->declared_at
);
576 sym
->result
->attr
.untyped
= 1;
580 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
581 type, lists the only ways a character length value of * can be used:
582 dummy arguments of procedures, named constants, and function results
583 in external functions. Internal function results and results of module
584 procedures are not on this list, ergo, not permitted. */
586 if (sym
->result
->ts
.type
== BT_CHARACTER
)
588 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
589 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
591 /* See if this is a module-procedure and adapt error message
594 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
595 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
597 gfc_error ("Character-valued %s '%s' at %L must not be"
599 module_proc
? _("module procedure")
600 : _("internal function"),
601 sym
->name
, &sym
->declared_at
);
607 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
608 introduce duplicates. */
611 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
613 gfc_formal_arglist
*f
, *new_arglist
;
616 for (; new_args
!= NULL
; new_args
= new_args
->next
)
618 new_sym
= new_args
->sym
;
619 /* See if this arg is already in the formal argument list. */
620 for (f
= proc
->formal
; f
; f
= f
->next
)
622 if (new_sym
== f
->sym
)
629 /* Add a new argument. Argument order is not important. */
630 new_arglist
= gfc_get_formal_arglist ();
631 new_arglist
->sym
= new_sym
;
632 new_arglist
->next
= proc
->formal
;
633 proc
->formal
= new_arglist
;
638 /* Flag the arguments that are not present in all entries. */
641 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
643 gfc_formal_arglist
*f
, *head
;
646 for (f
= proc
->formal
; f
; f
= f
->next
)
651 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
653 if (new_args
->sym
== f
->sym
)
660 f
->sym
->attr
.not_always_present
= 1;
665 /* Resolve alternate entry points. If a symbol has multiple entry points we
666 create a new master symbol for the main routine, and turn the existing
667 symbol into an entry point. */
670 resolve_entries (gfc_namespace
*ns
)
672 gfc_namespace
*old_ns
;
676 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
677 static int master_count
= 0;
679 if (ns
->proc_name
== NULL
)
682 /* No need to do anything if this procedure doesn't have alternate entry
687 /* We may already have resolved alternate entry points. */
688 if (ns
->proc_name
->attr
.entry_master
)
691 /* If this isn't a procedure something has gone horribly wrong. */
692 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
694 /* Remember the current namespace. */
695 old_ns
= gfc_current_ns
;
699 /* Add the main entry point to the list of entry points. */
700 el
= gfc_get_entry_list ();
701 el
->sym
= ns
->proc_name
;
703 el
->next
= ns
->entries
;
705 ns
->proc_name
->attr
.entry
= 1;
707 /* If it is a module function, it needs to be in the right namespace
708 so that gfc_get_fake_result_decl can gather up the results. The
709 need for this arose in get_proc_name, where these beasts were
710 left in their own namespace, to keep prior references linked to
711 the entry declaration.*/
712 if (ns
->proc_name
->attr
.function
713 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
716 /* Do the same for entries where the master is not a module
717 procedure. These are retained in the module namespace because
718 of the module procedure declaration. */
719 for (el
= el
->next
; el
; el
= el
->next
)
720 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
721 && el
->sym
->attr
.mod_proc
)
725 /* Add an entry statement for it. */
726 c
= gfc_get_code (EXEC_ENTRY
);
731 /* Create a new symbol for the master function. */
732 /* Give the internal function a unique name (within this file).
733 Also include the function name so the user has some hope of figuring
734 out what is going on. */
735 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
736 master_count
++, ns
->proc_name
->name
);
737 gfc_get_ha_symbol (name
, &proc
);
738 gcc_assert (proc
!= NULL
);
740 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
741 if (ns
->proc_name
->attr
.subroutine
)
742 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
746 gfc_typespec
*ts
, *fts
;
747 gfc_array_spec
*as
, *fas
;
748 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
750 fas
= ns
->entries
->sym
->as
;
751 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
752 fts
= &ns
->entries
->sym
->result
->ts
;
753 if (fts
->type
== BT_UNKNOWN
)
754 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
755 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
757 ts
= &el
->sym
->result
->ts
;
759 as
= as
? as
: el
->sym
->result
->as
;
760 if (ts
->type
== BT_UNKNOWN
)
761 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
763 if (! gfc_compare_types (ts
, fts
)
764 || (el
->sym
->result
->attr
.dimension
765 != ns
->entries
->sym
->result
->attr
.dimension
)
766 || (el
->sym
->result
->attr
.pointer
767 != ns
->entries
->sym
->result
->attr
.pointer
))
769 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
770 && gfc_compare_array_spec (as
, fas
) == 0)
771 gfc_error ("Function %s at %L has entries with mismatched "
772 "array specifications", ns
->entries
->sym
->name
,
773 &ns
->entries
->sym
->declared_at
);
774 /* The characteristics need to match and thus both need to have
775 the same string length, i.e. both len=*, or both len=4.
776 Having both len=<variable> is also possible, but difficult to
777 check at compile time. */
778 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
779 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
780 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
782 && ts
->u
.cl
->length
->expr_type
783 != fts
->u
.cl
->length
->expr_type
)
785 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
786 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
787 fts
->u
.cl
->length
->value
.integer
) != 0)))
788 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
789 "entries returning variables of different "
790 "string lengths", ns
->entries
->sym
->name
,
791 &ns
->entries
->sym
->declared_at
);
796 sym
= ns
->entries
->sym
->result
;
797 /* All result types the same. */
799 if (sym
->attr
.dimension
)
800 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
801 if (sym
->attr
.pointer
)
802 gfc_add_pointer (&proc
->attr
, NULL
);
806 /* Otherwise the result will be passed through a union by
808 proc
->attr
.mixed_entry_master
= 1;
809 for (el
= ns
->entries
; el
; el
= el
->next
)
811 sym
= el
->sym
->result
;
812 if (sym
->attr
.dimension
)
814 if (el
== ns
->entries
)
815 gfc_error ("FUNCTION result %s can't be an array in "
816 "FUNCTION %s at %L", sym
->name
,
817 ns
->entries
->sym
->name
, &sym
->declared_at
);
819 gfc_error ("ENTRY result %s can't be an array in "
820 "FUNCTION %s at %L", sym
->name
,
821 ns
->entries
->sym
->name
, &sym
->declared_at
);
823 else if (sym
->attr
.pointer
)
825 if (el
== ns
->entries
)
826 gfc_error ("FUNCTION result %s can't be a POINTER in "
827 "FUNCTION %s at %L", sym
->name
,
828 ns
->entries
->sym
->name
, &sym
->declared_at
);
830 gfc_error ("ENTRY result %s can't be a POINTER in "
831 "FUNCTION %s at %L", sym
->name
,
832 ns
->entries
->sym
->name
, &sym
->declared_at
);
837 if (ts
->type
== BT_UNKNOWN
)
838 ts
= gfc_get_default_type (sym
->name
, NULL
);
842 if (ts
->kind
== gfc_default_integer_kind
)
846 if (ts
->kind
== gfc_default_real_kind
847 || ts
->kind
== gfc_default_double_kind
)
851 if (ts
->kind
== gfc_default_complex_kind
)
855 if (ts
->kind
== gfc_default_logical_kind
)
859 /* We will issue error elsewhere. */
867 if (el
== ns
->entries
)
868 gfc_error ("FUNCTION result %s can't be of type %s "
869 "in FUNCTION %s at %L", sym
->name
,
870 gfc_typename (ts
), ns
->entries
->sym
->name
,
873 gfc_error ("ENTRY result %s can't be of type %s "
874 "in FUNCTION %s at %L", sym
->name
,
875 gfc_typename (ts
), ns
->entries
->sym
->name
,
882 proc
->attr
.access
= ACCESS_PRIVATE
;
883 proc
->attr
.entry_master
= 1;
885 /* Merge all the entry point arguments. */
886 for (el
= ns
->entries
; el
; el
= el
->next
)
887 merge_argument_lists (proc
, el
->sym
->formal
);
889 /* Check the master formal arguments for any that are not
890 present in all entry points. */
891 for (el
= ns
->entries
; el
; el
= el
->next
)
892 check_argument_lists (proc
, el
->sym
->formal
);
894 /* Use the master function for the function body. */
895 ns
->proc_name
= proc
;
897 /* Finalize the new symbols. */
898 gfc_commit_symbols ();
900 /* Restore the original namespace. */
901 gfc_current_ns
= old_ns
;
905 /* Resolve common variables. */
907 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
909 gfc_symbol
*csym
= sym
;
911 for (; csym
; csym
= csym
->common_next
)
913 if (csym
->value
|| csym
->attr
.data
)
915 if (!csym
->ns
->is_block_data
)
916 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
917 "but only in BLOCK DATA initialization is "
918 "allowed", csym
->name
, &csym
->declared_at
);
919 else if (!named_common
)
920 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
921 "in a blank COMMON but initialization is only "
922 "allowed in named common blocks", csym
->name
,
926 if (UNLIMITED_POLY (csym
))
927 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
928 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
930 if (csym
->ts
.type
!= BT_DERIVED
)
933 if (!(csym
->ts
.u
.derived
->attr
.sequence
934 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
935 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
936 "has neither the SEQUENCE nor the BIND(C) "
937 "attribute", csym
->name
, &csym
->declared_at
);
938 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
939 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
940 "has an ultimate component that is "
941 "allocatable", csym
->name
, &csym
->declared_at
);
942 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
943 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
944 "may not have default initializer", csym
->name
,
947 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
948 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
952 /* Resolve common blocks. */
954 resolve_common_blocks (gfc_symtree
*common_root
)
959 if (common_root
== NULL
)
962 if (common_root
->left
)
963 resolve_common_blocks (common_root
->left
);
964 if (common_root
->right
)
965 resolve_common_blocks (common_root
->right
);
967 resolve_common_vars (common_root
->n
.common
->head
, true);
969 /* The common name is a global name - in Fortran 2003 also if it has a
970 C binding name, since Fortran 2008 only the C binding name is a global
972 if (!common_root
->n
.common
->binding_label
973 || gfc_notification_std (GFC_STD_F2008
))
975 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
976 common_root
->n
.common
->name
);
978 if (gsym
&& gfc_notification_std (GFC_STD_F2008
)
979 && gsym
->type
== GSYM_COMMON
980 && ((common_root
->n
.common
->binding_label
981 && (!gsym
->binding_label
982 || strcmp (common_root
->n
.common
->binding_label
,
983 gsym
->binding_label
) != 0))
984 || (!common_root
->n
.common
->binding_label
985 && gsym
->binding_label
)))
987 gfc_error ("In Fortran 2003 COMMON '%s' block at %L is a global "
988 "identifier and must thus have the same binding name "
989 "as the same-named COMMON block at %L: %s vs %s",
990 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
992 common_root
->n
.common
->binding_label
993 ? common_root
->n
.common
->binding_label
: "(blank)",
994 gsym
->binding_label
? gsym
->binding_label
: "(blank)");
998 if (gsym
&& gsym
->type
!= GSYM_COMMON
999 && !common_root
->n
.common
->binding_label
)
1001 gfc_error ("COMMON block '%s' at %L uses the same global identifier "
1003 common_root
->n
.common
->name
, &common_root
->n
.common
->where
,
1007 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1009 gfc_error ("Fortran 2008: COMMON block '%s' with binding label at "
1010 "%L sharing the identifier with global non-COMMON-block "
1011 "entity at %L", common_root
->n
.common
->name
,
1012 &common_root
->n
.common
->where
, &gsym
->where
);
1017 gsym
= gfc_get_gsymbol (common_root
->n
.common
->name
);
1018 gsym
->type
= GSYM_COMMON
;
1019 gsym
->where
= common_root
->n
.common
->where
;
1025 if (common_root
->n
.common
->binding_label
)
1027 gsym
= gfc_find_gsymbol (gfc_gsym_root
,
1028 common_root
->n
.common
->binding_label
);
1029 if (gsym
&& gsym
->type
!= GSYM_COMMON
)
1031 gfc_error ("COMMON block at %L with binding label %s uses the same "
1032 "global identifier as entity at %L",
1033 &common_root
->n
.common
->where
,
1034 common_root
->n
.common
->binding_label
, &gsym
->where
);
1039 gsym
= gfc_get_gsymbol (common_root
->n
.common
->binding_label
);
1040 gsym
->type
= GSYM_COMMON
;
1041 gsym
->where
= common_root
->n
.common
->where
;
1047 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
1051 if (sym
->attr
.flavor
== FL_PARAMETER
)
1052 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
1053 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
1055 if (sym
->attr
.external
)
1056 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
1057 sym
->name
, &common_root
->n
.common
->where
);
1059 if (sym
->attr
.intrinsic
)
1060 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
1061 sym
->name
, &common_root
->n
.common
->where
);
1062 else if (sym
->attr
.result
1063 || gfc_is_function_return_value (sym
, gfc_current_ns
))
1064 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1065 "that is also a function result", sym
->name
,
1066 &common_root
->n
.common
->where
);
1067 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
1068 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
1069 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
1070 "that is also a global procedure", sym
->name
,
1071 &common_root
->n
.common
->where
);
1075 /* Resolve contained function types. Because contained functions can call one
1076 another, they have to be worked out before any of the contained procedures
1079 The good news is that if a function doesn't already have a type, the only
1080 way it can get one is through an IMPLICIT type or a RESULT variable, because
1081 by definition contained functions are contained namespace they're contained
1082 in, not in a sibling or parent namespace. */
1085 resolve_contained_functions (gfc_namespace
*ns
)
1087 gfc_namespace
*child
;
1090 resolve_formal_arglists (ns
);
1092 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1094 /* Resolve alternate entry points first. */
1095 resolve_entries (child
);
1097 /* Then check function return types. */
1098 resolve_contained_fntype (child
->proc_name
, child
);
1099 for (el
= child
->entries
; el
; el
= el
->next
)
1100 resolve_contained_fntype (el
->sym
, child
);
1105 static bool resolve_fl_derived0 (gfc_symbol
*sym
);
1108 /* Resolve all of the elements of a structure constructor and make sure that
1109 the types are correct. The 'init' flag indicates that the given
1110 constructor is an initializer. */
1113 resolve_structure_cons (gfc_expr
*expr
, int init
)
1115 gfc_constructor
*cons
;
1116 gfc_component
*comp
;
1122 if (expr
->ts
.type
== BT_DERIVED
)
1123 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1125 cons
= gfc_constructor_first (expr
->value
.constructor
);
1127 /* A constructor may have references if it is the result of substituting a
1128 parameter variable. In this case we just pull out the component we
1131 comp
= expr
->ref
->u
.c
.sym
->components
;
1133 comp
= expr
->ts
.u
.derived
->components
;
1135 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1142 if (!gfc_resolve_expr (cons
->expr
))
1148 rank
= comp
->as
? comp
->as
->rank
: 0;
1149 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1150 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1152 gfc_error ("The rank of the element in the structure "
1153 "constructor at %L does not match that of the "
1154 "component (%d/%d)", &cons
->expr
->where
,
1155 cons
->expr
->rank
, rank
);
1159 /* If we don't have the right type, try to convert it. */
1161 if (!comp
->attr
.proc_pointer
&&
1162 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1164 if (strcmp (comp
->name
, "_extends") == 0)
1166 /* Can afford to be brutal with the _extends initializer.
1167 The derived type can get lost because it is PRIVATE
1168 but it is not usage constrained by the standard. */
1169 cons
->expr
->ts
= comp
->ts
;
1171 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1173 gfc_error ("The element in the structure constructor at %L, "
1174 "for pointer component '%s', is %s but should be %s",
1175 &cons
->expr
->where
, comp
->name
,
1176 gfc_basic_typename (cons
->expr
->ts
.type
),
1177 gfc_basic_typename (comp
->ts
.type
));
1182 bool t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1188 /* For strings, the length of the constructor should be the same as
1189 the one of the structure, ensure this if the lengths are known at
1190 compile time and when we are dealing with PARAMETER or structure
1192 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1193 && comp
->ts
.u
.cl
->length
1194 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1195 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1196 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1197 && cons
->expr
->rank
!= 0
1198 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1199 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1201 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1202 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1204 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1205 to make use of the gfc_resolve_character_array_constructor
1206 machinery. The expression is later simplified away to
1207 an array of string literals. */
1208 gfc_expr
*para
= cons
->expr
;
1209 cons
->expr
= gfc_get_expr ();
1210 cons
->expr
->ts
= para
->ts
;
1211 cons
->expr
->where
= para
->where
;
1212 cons
->expr
->expr_type
= EXPR_ARRAY
;
1213 cons
->expr
->rank
= para
->rank
;
1214 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1215 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1216 para
, &cons
->expr
->where
);
1218 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1221 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1222 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1224 gfc_charlen
*cl
, *cl2
;
1227 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1229 if (cl
== cons
->expr
->ts
.u
.cl
)
1237 cl2
->next
= cl
->next
;
1239 gfc_free_expr (cl
->length
);
1243 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1244 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1245 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1246 gfc_resolve_character_array_constructor (cons
->expr
);
1250 if (cons
->expr
->expr_type
== EXPR_NULL
1251 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1252 || comp
->attr
.proc_pointer
|| comp
->ts
.f90_type
== BT_VOID
1253 || (comp
->ts
.type
== BT_CLASS
1254 && (CLASS_DATA (comp
)->attr
.class_pointer
1255 || CLASS_DATA (comp
)->attr
.allocatable
))))
1258 gfc_error ("The NULL in the structure constructor at %L is "
1259 "being applied to component '%s', which is neither "
1260 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1264 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1266 /* Check procedure pointer interface. */
1267 gfc_symbol
*s2
= NULL
;
1272 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1275 s2
= c2
->ts
.interface
;
1278 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1280 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1281 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1283 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1285 s2
= cons
->expr
->symtree
->n
.sym
;
1286 name
= cons
->expr
->symtree
->n
.sym
->name
;
1289 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1290 err
, sizeof (err
), NULL
, NULL
))
1292 gfc_error ("Interface mismatch for procedure-pointer component "
1293 "'%s' in structure constructor at %L: %s",
1294 comp
->name
, &cons
->expr
->where
, err
);
1299 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1300 || cons
->expr
->expr_type
== EXPR_NULL
)
1303 a
= gfc_expr_attr (cons
->expr
);
1305 if (!a
.pointer
&& !a
.target
)
1308 gfc_error ("The element in the structure constructor at %L, "
1309 "for pointer component '%s' should be a POINTER or "
1310 "a TARGET", &cons
->expr
->where
, comp
->name
);
1315 /* F08:C461. Additional checks for pointer initialization. */
1319 gfc_error ("Pointer initialization target at %L "
1320 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1325 gfc_error ("Pointer initialization target at %L "
1326 "must have the SAVE attribute", &cons
->expr
->where
);
1330 /* F2003, C1272 (3). */
1331 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1332 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1333 || gfc_is_coindexed (cons
->expr
)))
1336 gfc_error ("Invalid expression in the structure constructor for "
1337 "pointer component '%s' at %L in PURE procedure",
1338 comp
->name
, &cons
->expr
->where
);
1341 if (gfc_implicit_pure (NULL
)
1342 && cons
->expr
->expr_type
== EXPR_VARIABLE
1343 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1344 || gfc_is_coindexed (cons
->expr
)))
1345 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1353 /****************** Expression name resolution ******************/
1355 /* Returns 0 if a symbol was not declared with a type or
1356 attribute declaration statement, nonzero otherwise. */
1359 was_declared (gfc_symbol
*sym
)
1365 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1368 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1369 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1370 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1371 || a
.asynchronous
|| a
.codimension
)
1378 /* Determine if a symbol is generic or not. */
1381 generic_sym (gfc_symbol
*sym
)
1385 if (sym
->attr
.generic
||
1386 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1389 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1392 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1399 return generic_sym (s
);
1406 /* Determine if a symbol is specific or not. */
1409 specific_sym (gfc_symbol
*sym
)
1413 if (sym
->attr
.if_source
== IFSRC_IFBODY
1414 || sym
->attr
.proc
== PROC_MODULE
1415 || sym
->attr
.proc
== PROC_INTERNAL
1416 || sym
->attr
.proc
== PROC_ST_FUNCTION
1417 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1418 || sym
->attr
.external
)
1421 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1424 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1426 return (s
== NULL
) ? 0 : specific_sym (s
);
1430 /* Figure out if the procedure is specific, generic or unknown. */
1433 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1437 procedure_kind (gfc_symbol
*sym
)
1439 if (generic_sym (sym
))
1440 return PTYPE_GENERIC
;
1442 if (specific_sym (sym
))
1443 return PTYPE_SPECIFIC
;
1445 return PTYPE_UNKNOWN
;
1448 /* Check references to assumed size arrays. The flag need_full_assumed_size
1449 is nonzero when matching actual arguments. */
1451 static int need_full_assumed_size
= 0;
1454 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1456 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1459 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1460 What should it be? */
1461 if (e
->ref
&& (e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1462 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1463 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1465 gfc_error ("The upper bound in the last dimension must "
1466 "appear in the reference to the assumed size "
1467 "array '%s' at %L", sym
->name
, &e
->where
);
1474 /* Look for bad assumed size array references in argument expressions
1475 of elemental and array valued intrinsic procedures. Since this is
1476 called from procedure resolution functions, it only recurses at
1480 resolve_assumed_size_actual (gfc_expr
*e
)
1485 switch (e
->expr_type
)
1488 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1493 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1494 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1505 /* Check a generic procedure, passed as an actual argument, to see if
1506 there is a matching specific name. If none, it is an error, and if
1507 more than one, the reference is ambiguous. */
1509 count_specific_procs (gfc_expr
*e
)
1516 sym
= e
->symtree
->n
.sym
;
1518 for (p
= sym
->generic
; p
; p
= p
->next
)
1519 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1521 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1527 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1531 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1532 "argument at %L", sym
->name
, &e
->where
);
1538 /* See if a call to sym could possibly be a not allowed RECURSION because of
1539 a missing RECURSIVE declaration. This means that either sym is the current
1540 context itself, or sym is the parent of a contained procedure calling its
1541 non-RECURSIVE containing procedure.
1542 This also works if sym is an ENTRY. */
1545 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1547 gfc_symbol
* proc_sym
;
1548 gfc_symbol
* context_proc
;
1549 gfc_namespace
* real_context
;
1551 if (sym
->attr
.flavor
== FL_PROGRAM
1552 || sym
->attr
.flavor
== FL_DERIVED
)
1555 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1557 /* If we've got an ENTRY, find real procedure. */
1558 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1559 proc_sym
= sym
->ns
->entries
->sym
;
1563 /* If sym is RECURSIVE, all is well of course. */
1564 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1567 /* Find the context procedure's "real" symbol if it has entries.
1568 We look for a procedure symbol, so recurse on the parents if we don't
1569 find one (like in case of a BLOCK construct). */
1570 for (real_context
= context
; ; real_context
= real_context
->parent
)
1572 /* We should find something, eventually! */
1573 gcc_assert (real_context
);
1575 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1576 : real_context
->proc_name
);
1578 /* In some special cases, there may not be a proc_name, like for this
1580 real(bad_kind()) function foo () ...
1581 when checking the call to bad_kind ().
1582 In these cases, we simply return here and assume that the
1587 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1591 /* A call from sym's body to itself is recursion, of course. */
1592 if (context_proc
== proc_sym
)
1595 /* The same is true if context is a contained procedure and sym the
1597 if (context_proc
->attr
.contained
)
1599 gfc_symbol
* parent_proc
;
1601 gcc_assert (context
->parent
);
1602 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1603 : context
->parent
->proc_name
);
1605 if (parent_proc
== proc_sym
)
1613 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1614 its typespec and formal argument list. */
1617 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1619 gfc_intrinsic_sym
* isym
= NULL
;
1625 /* Already resolved. */
1626 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1629 /* We already know this one is an intrinsic, so we don't call
1630 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1631 gfc_find_subroutine directly to check whether it is a function or
1634 if (sym
->intmod_sym_id
&& sym
->attr
.subroutine
)
1636 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1637 isym
= gfc_intrinsic_subroutine_by_id (id
);
1639 else if (sym
->intmod_sym_id
)
1641 gfc_isym_id id
= gfc_isym_id_by_intmod_sym (sym
);
1642 isym
= gfc_intrinsic_function_by_id (id
);
1644 else if (!sym
->attr
.subroutine
)
1645 isym
= gfc_find_function (sym
->name
);
1647 if (isym
&& !sym
->attr
.subroutine
)
1649 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1650 && !sym
->attr
.implicit_type
)
1651 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1652 " ignored", sym
->name
, &sym
->declared_at
);
1654 if (!sym
->attr
.function
&&
1655 !gfc_add_function(&sym
->attr
, sym
->name
, loc
))
1660 else if (isym
|| (isym
= gfc_find_subroutine (sym
->name
)))
1662 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1664 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1665 " specifier", sym
->name
, &sym
->declared_at
);
1669 if (!sym
->attr
.subroutine
&&
1670 !gfc_add_subroutine(&sym
->attr
, sym
->name
, loc
))
1675 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1680 gfc_copy_formal_args_intr (sym
, isym
);
1682 /* Check it is actually available in the standard settings. */
1683 if (!gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
))
1685 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1686 " available in the current standard settings but %s. Use"
1687 " an appropriate -std=* option or enable -fall-intrinsics"
1688 " in order to use it.",
1689 sym
->name
, &sym
->declared_at
, symstd
);
1697 /* Resolve a procedure expression, like passing it to a called procedure or as
1698 RHS for a procedure pointer assignment. */
1701 resolve_procedure_expression (gfc_expr
* expr
)
1705 if (expr
->expr_type
!= EXPR_VARIABLE
)
1707 gcc_assert (expr
->symtree
);
1709 sym
= expr
->symtree
->n
.sym
;
1711 if (sym
->attr
.intrinsic
)
1712 gfc_resolve_intrinsic (sym
, &expr
->where
);
1714 if (sym
->attr
.flavor
!= FL_PROCEDURE
1715 || (sym
->attr
.function
&& sym
->result
== sym
))
1718 /* A non-RECURSIVE procedure that is used as procedure expression within its
1719 own body is in danger of being called recursively. */
1720 if (is_illegal_recursion (sym
, gfc_current_ns
))
1721 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1722 " itself recursively. Declare it RECURSIVE or use"
1723 " -frecursive", sym
->name
, &expr
->where
);
1729 /* Resolve an actual argument list. Most of the time, this is just
1730 resolving the expressions in the list.
1731 The exception is that we sometimes have to decide whether arguments
1732 that look like procedure arguments are really simple variable
1736 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1737 bool no_formal_args
)
1740 gfc_symtree
*parent_st
;
1742 int save_need_full_assumed_size
;
1743 bool return_value
= false;
1744 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1747 first_actual_arg
= true;
1749 for (; arg
; arg
= arg
->next
)
1754 /* Check the label is a valid branching target. */
1757 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1759 gfc_error ("Label %d referenced at %L is never defined",
1760 arg
->label
->value
, &arg
->label
->where
);
1764 first_actual_arg
= false;
1768 if (e
->expr_type
== EXPR_VARIABLE
1769 && e
->symtree
->n
.sym
->attr
.generic
1771 && count_specific_procs (e
) != 1)
1774 if (e
->ts
.type
!= BT_PROCEDURE
)
1776 save_need_full_assumed_size
= need_full_assumed_size
;
1777 if (e
->expr_type
!= EXPR_VARIABLE
)
1778 need_full_assumed_size
= 0;
1779 if (!gfc_resolve_expr (e
))
1781 need_full_assumed_size
= save_need_full_assumed_size
;
1785 /* See if the expression node should really be a variable reference. */
1787 sym
= e
->symtree
->n
.sym
;
1789 if (sym
->attr
.flavor
== FL_PROCEDURE
1790 || sym
->attr
.intrinsic
1791 || sym
->attr
.external
)
1795 /* If a procedure is not already determined to be something else
1796 check if it is intrinsic. */
1797 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1798 sym
->attr
.intrinsic
= 1;
1800 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1802 gfc_error ("Statement function '%s' at %L is not allowed as an "
1803 "actual argument", sym
->name
, &e
->where
);
1806 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1807 sym
->attr
.subroutine
);
1808 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1810 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1811 "actual argument", sym
->name
, &e
->where
);
1814 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1815 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1817 if (!gfc_notify_std (GFC_STD_F2008
, "Internal procedure '%s' is"
1818 " used as actual argument at %L",
1819 sym
->name
, &e
->where
))
1823 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1825 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1826 "allowed as an actual argument at %L", sym
->name
,
1830 /* Check if a generic interface has a specific procedure
1831 with the same name before emitting an error. */
1832 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1835 /* Just in case a specific was found for the expression. */
1836 sym
= e
->symtree
->n
.sym
;
1838 /* If the symbol is the function that names the current (or
1839 parent) scope, then we really have a variable reference. */
1841 if (gfc_is_function_return_value (sym
, sym
->ns
))
1844 /* If all else fails, see if we have a specific intrinsic. */
1845 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1847 gfc_intrinsic_sym
*isym
;
1849 isym
= gfc_find_function (sym
->name
);
1850 if (isym
== NULL
|| !isym
->specific
)
1852 gfc_error ("Unable to find a specific INTRINSIC procedure "
1853 "for the reference '%s' at %L", sym
->name
,
1858 sym
->attr
.intrinsic
= 1;
1859 sym
->attr
.function
= 1;
1862 if (!gfc_resolve_expr (e
))
1867 /* See if the name is a module procedure in a parent unit. */
1869 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1872 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1874 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1878 if (parent_st
== NULL
)
1881 sym
= parent_st
->n
.sym
;
1882 e
->symtree
= parent_st
; /* Point to the right thing. */
1884 if (sym
->attr
.flavor
== FL_PROCEDURE
1885 || sym
->attr
.intrinsic
1886 || sym
->attr
.external
)
1888 if (!gfc_resolve_expr (e
))
1894 e
->expr_type
= EXPR_VARIABLE
;
1896 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1897 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1898 && CLASS_DATA (sym
)->as
))
1900 e
->rank
= sym
->ts
.type
== BT_CLASS
1901 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1902 e
->ref
= gfc_get_ref ();
1903 e
->ref
->type
= REF_ARRAY
;
1904 e
->ref
->u
.ar
.type
= AR_FULL
;
1905 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1906 ? CLASS_DATA (sym
)->as
: sym
->as
;
1909 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1910 primary.c (match_actual_arg). If above code determines that it
1911 is a variable instead, it needs to be resolved as it was not
1912 done at the beginning of this function. */
1913 save_need_full_assumed_size
= need_full_assumed_size
;
1914 if (e
->expr_type
!= EXPR_VARIABLE
)
1915 need_full_assumed_size
= 0;
1916 if (!gfc_resolve_expr (e
))
1918 need_full_assumed_size
= save_need_full_assumed_size
;
1921 /* Check argument list functions %VAL, %LOC and %REF. There is
1922 nothing to do for %REF. */
1923 if (arg
->name
&& arg
->name
[0] == '%')
1925 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1927 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1929 gfc_error ("By-value argument at %L is not of numeric "
1936 gfc_error ("By-value argument at %L cannot be an array or "
1937 "an array section", &e
->where
);
1941 /* Intrinsics are still PROC_UNKNOWN here. However,
1942 since same file external procedures are not resolvable
1943 in gfortran, it is a good deal easier to leave them to
1945 if (ptype
!= PROC_UNKNOWN
1946 && ptype
!= PROC_DUMMY
1947 && ptype
!= PROC_EXTERNAL
1948 && ptype
!= PROC_MODULE
)
1950 gfc_error ("By-value argument at %L is not allowed "
1951 "in this context", &e
->where
);
1956 /* Statement functions have already been excluded above. */
1957 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1958 && e
->ts
.type
== BT_PROCEDURE
)
1960 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1962 gfc_error ("Passing internal procedure at %L by location "
1963 "not allowed", &e
->where
);
1969 /* Fortran 2008, C1237. */
1970 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1971 && gfc_has_ultimate_pointer (e
))
1973 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1974 "component", &e
->where
);
1978 first_actual_arg
= false;
1981 return_value
= true;
1984 actual_arg
= actual_arg_sav
;
1985 first_actual_arg
= first_actual_arg_sav
;
1987 return return_value
;
1991 /* Do the checks of the actual argument list that are specific to elemental
1992 procedures. If called with c == NULL, we have a function, otherwise if
1993 expr == NULL, we have a subroutine. */
1996 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1998 gfc_actual_arglist
*arg0
;
1999 gfc_actual_arglist
*arg
;
2000 gfc_symbol
*esym
= NULL
;
2001 gfc_intrinsic_sym
*isym
= NULL
;
2003 gfc_intrinsic_arg
*iformal
= NULL
;
2004 gfc_formal_arglist
*eformal
= NULL
;
2005 bool formal_optional
= false;
2006 bool set_by_optional
= false;
2010 /* Is this an elemental procedure? */
2011 if (expr
&& expr
->value
.function
.actual
!= NULL
)
2013 if (expr
->value
.function
.esym
!= NULL
2014 && expr
->value
.function
.esym
->attr
.elemental
)
2016 arg0
= expr
->value
.function
.actual
;
2017 esym
= expr
->value
.function
.esym
;
2019 else if (expr
->value
.function
.isym
!= NULL
2020 && expr
->value
.function
.isym
->elemental
)
2022 arg0
= expr
->value
.function
.actual
;
2023 isym
= expr
->value
.function
.isym
;
2028 else if (c
&& c
->ext
.actual
!= NULL
)
2030 arg0
= c
->ext
.actual
;
2032 if (c
->resolved_sym
)
2033 esym
= c
->resolved_sym
;
2035 esym
= c
->symtree
->n
.sym
;
2038 if (!esym
->attr
.elemental
)
2044 /* The rank of an elemental is the rank of its array argument(s). */
2045 for (arg
= arg0
; arg
; arg
= arg
->next
)
2047 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
2049 rank
= arg
->expr
->rank
;
2050 if (arg
->expr
->expr_type
== EXPR_VARIABLE
2051 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
2052 set_by_optional
= true;
2054 /* Function specific; set the result rank and shape. */
2058 if (!expr
->shape
&& arg
->expr
->shape
)
2060 expr
->shape
= gfc_get_shape (rank
);
2061 for (i
= 0; i
< rank
; i
++)
2062 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
2069 /* If it is an array, it shall not be supplied as an actual argument
2070 to an elemental procedure unless an array of the same rank is supplied
2071 as an actual argument corresponding to a nonoptional dummy argument of
2072 that elemental procedure(12.4.1.5). */
2073 formal_optional
= false;
2075 iformal
= isym
->formal
;
2077 eformal
= esym
->formal
;
2079 for (arg
= arg0
; arg
; arg
= arg
->next
)
2083 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2084 formal_optional
= true;
2085 eformal
= eformal
->next
;
2087 else if (isym
&& iformal
)
2089 if (iformal
->optional
)
2090 formal_optional
= true;
2091 iformal
= iformal
->next
;
2094 formal_optional
= true;
2096 if (pedantic
&& arg
->expr
!= NULL
2097 && arg
->expr
->expr_type
== EXPR_VARIABLE
2098 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2101 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2102 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2104 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2105 "MISSING, it cannot be the actual argument of an "
2106 "ELEMENTAL procedure unless there is a non-optional "
2107 "argument with the same rank (12.4.1.5)",
2108 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2112 for (arg
= arg0
; arg
; arg
= arg
->next
)
2114 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2117 /* Being elemental, the last upper bound of an assumed size array
2118 argument must be present. */
2119 if (resolve_assumed_size_actual (arg
->expr
))
2122 /* Elemental procedure's array actual arguments must conform. */
2125 if (!gfc_check_conformance (arg
->expr
, e
, "elemental procedure"))
2132 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2133 is an array, the intent inout/out variable needs to be also an array. */
2134 if (rank
> 0 && esym
&& expr
== NULL
)
2135 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2136 arg
= arg
->next
, eformal
= eformal
->next
)
2137 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2138 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2139 && arg
->expr
&& arg
->expr
->rank
== 0)
2141 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2142 "ELEMENTAL subroutine '%s' is a scalar, but another "
2143 "actual argument is an array", &arg
->expr
->where
,
2144 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2145 : "INOUT", eformal
->sym
->name
, esym
->name
);
2152 /* This function does the checking of references to global procedures
2153 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2154 77 and 95 standards. It checks for a gsymbol for the name, making
2155 one if it does not already exist. If it already exists, then the
2156 reference being resolved must correspond to the type of gsymbol.
2157 Otherwise, the new symbol is equipped with the attributes of the
2158 reference. The corresponding code that is called in creating
2159 global entities is parse.c.
2161 In addition, for all but -std=legacy, the gsymbols are used to
2162 check the interfaces of external procedures from the same file.
2163 The namespace of the gsymbol is resolved and then, once this is
2164 done the interface is checked. */
2168 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2170 if (!gsym_ns
->proc_name
->attr
.recursive
)
2173 if (sym
->ns
== gsym_ns
)
2176 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2183 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2185 if (gsym_ns
->entries
)
2187 gfc_entry_list
*entry
= gsym_ns
->entries
;
2189 for (; entry
; entry
= entry
->next
)
2191 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2193 if (strcmp (gsym_ns
->proc_name
->name
,
2194 sym
->ns
->proc_name
->name
) == 0)
2198 && strcmp (gsym_ns
->proc_name
->name
,
2199 sym
->ns
->parent
->proc_name
->name
) == 0)
2208 /* Check for the requirement of an explicit interface. F08:12.4.2.2. */
2211 gfc_explicit_interface_required (gfc_symbol
*sym
, char *errmsg
, int err_len
)
2213 gfc_formal_arglist
*arg
= gfc_sym_get_dummy_args (sym
);
2215 for ( ; arg
; arg
= arg
->next
)
2220 if (arg
->sym
->attr
.allocatable
) /* (2a) */
2222 strncpy (errmsg
, _("allocatable argument"), err_len
);
2225 else if (arg
->sym
->attr
.asynchronous
)
2227 strncpy (errmsg
, _("asynchronous argument"), err_len
);
2230 else if (arg
->sym
->attr
.optional
)
2232 strncpy (errmsg
, _("optional argument"), err_len
);
2235 else if (arg
->sym
->attr
.pointer
)
2237 strncpy (errmsg
, _("pointer argument"), err_len
);
2240 else if (arg
->sym
->attr
.target
)
2242 strncpy (errmsg
, _("target argument"), err_len
);
2245 else if (arg
->sym
->attr
.value
)
2247 strncpy (errmsg
, _("value argument"), err_len
);
2250 else if (arg
->sym
->attr
.volatile_
)
2252 strncpy (errmsg
, _("volatile argument"), err_len
);
2255 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
) /* (2b) */
2257 strncpy (errmsg
, _("assumed-shape argument"), err_len
);
2260 else if (arg
->sym
->as
&& arg
->sym
->as
->type
== AS_ASSUMED_RANK
) /* TS 29113, 6.2. */
2262 strncpy (errmsg
, _("assumed-rank argument"), err_len
);
2265 else if (arg
->sym
->attr
.codimension
) /* (2c) */
2267 strncpy (errmsg
, _("coarray argument"), err_len
);
2270 else if (false) /* (2d) TODO: parametrized derived type */
2272 strncpy (errmsg
, _("parametrized derived type argument"), err_len
);
2275 else if (arg
->sym
->ts
.type
== BT_CLASS
) /* (2e) */
2277 strncpy (errmsg
, _("polymorphic argument"), err_len
);
2280 else if (arg
->sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
2282 strncpy (errmsg
, _("NO_ARG_CHECK attribute"), err_len
);
2285 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2287 /* As assumed-type is unlimited polymorphic (cf. above).
2288 See also TS 29113, Note 6.1. */
2289 strncpy (errmsg
, _("assumed-type argument"), err_len
);
2294 if (sym
->attr
.function
)
2296 gfc_symbol
*res
= sym
->result
? sym
->result
: sym
;
2298 if (res
->attr
.dimension
) /* (3a) */
2300 strncpy (errmsg
, _("array result"), err_len
);
2303 else if (res
->attr
.pointer
|| res
->attr
.allocatable
) /* (3b) */
2305 strncpy (errmsg
, _("pointer or allocatable result"), err_len
);
2308 else if (res
->ts
.type
== BT_CHARACTER
&& res
->ts
.u
.cl
2309 && res
->ts
.u
.cl
->length
2310 && res
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
) /* (3c) */
2312 strncpy (errmsg
, _("result with non-constant character length"), err_len
);
2317 if (sym
->attr
.elemental
) /* (4) */
2319 strncpy (errmsg
, _("elemental procedure"), err_len
);
2322 else if (sym
->attr
.is_bind_c
) /* (5) */
2324 strncpy (errmsg
, _("bind(c) procedure"), err_len
);
2333 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2334 gfc_actual_arglist
**actual
, int sub
)
2338 enum gfc_symbol_type type
;
2341 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2343 gsym
= gfc_get_gsymbol (sym
->binding_label
? sym
->binding_label
: sym
->name
);
2345 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2346 gfc_global_used (gsym
, where
);
2348 if ((sym
->attr
.if_source
== IFSRC_UNKNOWN
2349 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2350 && gsym
->type
!= GSYM_UNKNOWN
2352 && gsym
->ns
->resolved
!= -1
2353 && gsym
->ns
->proc_name
2354 && not_in_recursive (sym
, gsym
->ns
)
2355 && not_entry_self_reference (sym
, gsym
->ns
))
2357 gfc_symbol
*def_sym
;
2359 /* Resolve the gsymbol namespace if needed. */
2360 if (!gsym
->ns
->resolved
)
2362 gfc_dt_list
*old_dt_list
;
2363 struct gfc_omp_saved_state old_omp_state
;
2365 /* Stash away derived types so that the backend_decls do not
2367 old_dt_list
= gfc_derived_types
;
2368 gfc_derived_types
= NULL
;
2369 /* And stash away openmp state. */
2370 gfc_omp_save_and_clear_state (&old_omp_state
);
2372 gfc_resolve (gsym
->ns
);
2374 /* Store the new derived types with the global namespace. */
2375 if (gfc_derived_types
)
2376 gsym
->ns
->derived_types
= gfc_derived_types
;
2378 /* Restore the derived types of this namespace. */
2379 gfc_derived_types
= old_dt_list
;
2380 /* And openmp state. */
2381 gfc_omp_restore_state (&old_omp_state
);
2384 /* Make sure that translation for the gsymbol occurs before
2385 the procedure currently being resolved. */
2386 ns
= gfc_global_ns_list
;
2387 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2389 if (ns
->sibling
== gsym
->ns
)
2391 ns
->sibling
= gsym
->ns
->sibling
;
2392 gsym
->ns
->sibling
= gfc_global_ns_list
;
2393 gfc_global_ns_list
= gsym
->ns
;
2398 def_sym
= gsym
->ns
->proc_name
;
2400 /* This can happen if a binding name has been specified. */
2401 if (gsym
->binding_label
&& gsym
->sym_name
!= def_sym
->name
)
2402 gfc_find_symbol (gsym
->sym_name
, gsym
->ns
, 0, &def_sym
);
2404 if (def_sym
->attr
.entry_master
)
2406 gfc_entry_list
*entry
;
2407 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2408 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2410 def_sym
= entry
->sym
;
2415 if (sym
->attr
.function
&& !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2417 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2418 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2419 gfc_typename (&def_sym
->ts
));
2423 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
2424 && gfc_explicit_interface_required (def_sym
, reason
, sizeof(reason
)))
2426 gfc_error ("Explicit interface required for '%s' at %L: %s",
2427 sym
->name
, &sym
->declared_at
, reason
);
2431 if (!pedantic
&& (gfc_option
.allow_std
& GFC_STD_GNU
))
2432 /* Turn erros into warnings with -std=gnu and -std=legacy. */
2433 gfc_errors_to_warnings (1);
2435 if (!gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1,
2436 reason
, sizeof(reason
), NULL
, NULL
))
2438 gfc_error ("Interface mismatch in global procedure '%s' at %L: %s ",
2439 sym
->name
, &sym
->declared_at
, reason
);
2444 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2445 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2446 gfc_errors_to_warnings (1);
2448 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2449 gfc_procedure_use (def_sym
, actual
, where
);
2453 gfc_errors_to_warnings (0);
2455 if (gsym
->type
== GSYM_UNKNOWN
)
2458 gsym
->where
= *where
;
2465 /************* Function resolution *************/
2467 /* Resolve a function call known to be generic.
2468 Section 14.1.2.4.1. */
2471 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2475 if (sym
->attr
.generic
)
2477 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2480 expr
->value
.function
.name
= s
->name
;
2481 expr
->value
.function
.esym
= s
;
2483 if (s
->ts
.type
!= BT_UNKNOWN
)
2485 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2486 expr
->ts
= s
->result
->ts
;
2489 expr
->rank
= s
->as
->rank
;
2490 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2491 expr
->rank
= s
->result
->as
->rank
;
2493 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2498 /* TODO: Need to search for elemental references in generic
2502 if (sym
->attr
.intrinsic
)
2503 return gfc_intrinsic_func_interface (expr
, 0);
2510 resolve_generic_f (gfc_expr
*expr
)
2514 gfc_interface
*intr
= NULL
;
2516 sym
= expr
->symtree
->n
.sym
;
2520 m
= resolve_generic_f0 (expr
, sym
);
2523 else if (m
== MATCH_ERROR
)
2528 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2529 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2532 if (sym
->ns
->parent
== NULL
)
2534 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2538 if (!generic_sym (sym
))
2542 /* Last ditch attempt. See if the reference is to an intrinsic
2543 that possesses a matching interface. 14.1.2.4 */
2544 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2546 gfc_error ("There is no specific function for the generic '%s' "
2547 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2553 if (!gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
,
2556 return resolve_structure_cons (expr
, 0);
2559 m
= gfc_intrinsic_func_interface (expr
, 0);
2564 gfc_error ("Generic function '%s' at %L is not consistent with a "
2565 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2572 /* Resolve a function call known to be specific. */
2575 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2579 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2581 if (sym
->attr
.dummy
)
2583 sym
->attr
.proc
= PROC_DUMMY
;
2587 sym
->attr
.proc
= PROC_EXTERNAL
;
2591 if (sym
->attr
.proc
== PROC_MODULE
2592 || sym
->attr
.proc
== PROC_ST_FUNCTION
2593 || sym
->attr
.proc
== PROC_INTERNAL
)
2596 if (sym
->attr
.intrinsic
)
2598 m
= gfc_intrinsic_func_interface (expr
, 1);
2602 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2603 "with an intrinsic", sym
->name
, &expr
->where
);
2611 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2614 expr
->ts
= sym
->result
->ts
;
2617 expr
->value
.function
.name
= sym
->name
;
2618 expr
->value
.function
.esym
= sym
;
2619 if (sym
->as
!= NULL
)
2620 expr
->rank
= sym
->as
->rank
;
2627 resolve_specific_f (gfc_expr
*expr
)
2632 sym
= expr
->symtree
->n
.sym
;
2636 m
= resolve_specific_f0 (sym
, expr
);
2639 if (m
== MATCH_ERROR
)
2642 if (sym
->ns
->parent
== NULL
)
2645 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2651 gfc_error ("Unable to resolve the specific function '%s' at %L",
2652 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2658 /* Resolve a procedure call not known to be generic nor specific. */
2661 resolve_unknown_f (gfc_expr
*expr
)
2666 sym
= expr
->symtree
->n
.sym
;
2668 if (sym
->attr
.dummy
)
2670 sym
->attr
.proc
= PROC_DUMMY
;
2671 expr
->value
.function
.name
= sym
->name
;
2675 /* See if we have an intrinsic function reference. */
2677 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2679 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2684 /* The reference is to an external name. */
2686 sym
->attr
.proc
= PROC_EXTERNAL
;
2687 expr
->value
.function
.name
= sym
->name
;
2688 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2690 if (sym
->as
!= NULL
)
2691 expr
->rank
= sym
->as
->rank
;
2693 /* Type of the expression is either the type of the symbol or the
2694 default type of the symbol. */
2697 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2699 if (sym
->ts
.type
!= BT_UNKNOWN
)
2703 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2705 if (ts
->type
== BT_UNKNOWN
)
2707 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2708 sym
->name
, &expr
->where
);
2719 /* Return true, if the symbol is an external procedure. */
2721 is_external_proc (gfc_symbol
*sym
)
2723 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2724 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2725 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2726 && !sym
->attr
.proc_pointer
2727 && !sym
->attr
.use_assoc
2735 /* Figure out if a function reference is pure or not. Also set the name
2736 of the function for a potential error message. Return nonzero if the
2737 function is PURE, zero if not. */
2739 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2742 pure_function (gfc_expr
*e
, const char **name
)
2748 if (e
->symtree
!= NULL
2749 && e
->symtree
->n
.sym
!= NULL
2750 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2751 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2753 if (e
->value
.function
.esym
)
2755 pure
= gfc_pure (e
->value
.function
.esym
);
2756 *name
= e
->value
.function
.esym
->name
;
2758 else if (e
->value
.function
.isym
)
2760 pure
= e
->value
.function
.isym
->pure
2761 || e
->value
.function
.isym
->elemental
;
2762 *name
= e
->value
.function
.isym
->name
;
2766 /* Implicit functions are not pure. */
2768 *name
= e
->value
.function
.name
;
2776 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2777 int *f ATTRIBUTE_UNUSED
)
2781 /* Don't bother recursing into other statement functions
2782 since they will be checked individually for purity. */
2783 if (e
->expr_type
!= EXPR_FUNCTION
2785 || e
->symtree
->n
.sym
== sym
2786 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2789 return pure_function (e
, &name
) ? false : true;
2794 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2796 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2800 /* Resolve a function call, which means resolving the arguments, then figuring
2801 out which entity the name refers to. */
2804 resolve_function (gfc_expr
*expr
)
2806 gfc_actual_arglist
*arg
;
2811 procedure_type p
= PROC_INTRINSIC
;
2812 bool no_formal_args
;
2816 sym
= expr
->symtree
->n
.sym
;
2818 /* If this is a procedure pointer component, it has already been resolved. */
2819 if (gfc_is_proc_ptr_comp (expr
))
2822 if (sym
&& sym
->attr
.intrinsic
2823 && !gfc_resolve_intrinsic (sym
, &expr
->where
))
2826 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2828 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2832 /* If this ia a deferred TBP with an abstract interface (which may
2833 of course be referenced), expr->value.function.esym will be set. */
2834 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2836 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2837 sym
->name
, &expr
->where
);
2841 /* Switch off assumed size checking and do this again for certain kinds
2842 of procedure, once the procedure itself is resolved. */
2843 need_full_assumed_size
++;
2845 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2846 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2848 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2849 inquiry_argument
= true;
2850 no_formal_args
= sym
&& is_external_proc (sym
)
2851 && gfc_sym_get_dummy_args (sym
) == NULL
;
2853 if (!resolve_actual_arglist (expr
->value
.function
.actual
,
2856 inquiry_argument
= false;
2860 inquiry_argument
= false;
2862 /* Resume assumed_size checking. */
2863 need_full_assumed_size
--;
2865 /* If the procedure is external, check for usage. */
2866 if (sym
&& is_external_proc (sym
))
2867 resolve_global_procedure (sym
, &expr
->where
,
2868 &expr
->value
.function
.actual
, 0);
2870 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2872 && sym
->ts
.u
.cl
->length
== NULL
2874 && !sym
->ts
.deferred
2875 && expr
->value
.function
.esym
== NULL
2876 && !sym
->attr
.contained
)
2878 /* Internal procedures are taken care of in resolve_contained_fntype. */
2879 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2880 "be used at %L since it is not a dummy argument",
2881 sym
->name
, &expr
->where
);
2885 /* See if function is already resolved. */
2887 if (expr
->value
.function
.name
!= NULL
)
2889 if (expr
->ts
.type
== BT_UNKNOWN
)
2895 /* Apply the rules of section 14.1.2. */
2897 switch (procedure_kind (sym
))
2900 t
= resolve_generic_f (expr
);
2903 case PTYPE_SPECIFIC
:
2904 t
= resolve_specific_f (expr
);
2908 t
= resolve_unknown_f (expr
);
2912 gfc_internal_error ("resolve_function(): bad function type");
2916 /* If the expression is still a function (it might have simplified),
2917 then we check to see if we are calling an elemental function. */
2919 if (expr
->expr_type
!= EXPR_FUNCTION
)
2922 temp
= need_full_assumed_size
;
2923 need_full_assumed_size
= 0;
2925 if (!resolve_elemental_actual (expr
, NULL
))
2928 if (omp_workshare_flag
2929 && expr
->value
.function
.esym
2930 && ! gfc_elemental (expr
->value
.function
.esym
))
2932 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2933 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2938 #define GENERIC_ID expr->value.function.isym->id
2939 else if (expr
->value
.function
.actual
!= NULL
2940 && expr
->value
.function
.isym
!= NULL
2941 && GENERIC_ID
!= GFC_ISYM_LBOUND
2942 && GENERIC_ID
!= GFC_ISYM_LEN
2943 && GENERIC_ID
!= GFC_ISYM_LOC
2944 && GENERIC_ID
!= GFC_ISYM_C_LOC
2945 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2947 /* Array intrinsics must also have the last upper bound of an
2948 assumed size array argument. UBOUND and SIZE have to be
2949 excluded from the check if the second argument is anything
2952 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2954 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2955 && arg
== expr
->value
.function
.actual
2956 && arg
->next
!= NULL
&& arg
->next
->expr
)
2958 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2961 if (arg
->next
->name
&& strncmp (arg
->next
->name
, "kind", 4) == 0)
2964 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2969 if (arg
->expr
!= NULL
2970 && arg
->expr
->rank
> 0
2971 && resolve_assumed_size_actual (arg
->expr
))
2977 need_full_assumed_size
= temp
;
2980 if (!pure_function (expr
, &name
) && name
)
2984 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2985 "FORALL %s", name
, &expr
->where
,
2986 forall_flag
== 2 ? "mask" : "block");
2989 else if (gfc_do_concurrent_flag
)
2991 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
2992 "DO CONCURRENT %s", name
, &expr
->where
,
2993 gfc_do_concurrent_flag
== 2 ? "mask" : "block");
2996 else if (gfc_pure (NULL
))
2998 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2999 "procedure within a PURE procedure", name
, &expr
->where
);
3003 if (gfc_implicit_pure (NULL
))
3004 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3007 /* Functions without the RECURSIVE attribution are not allowed to
3008 * call themselves. */
3009 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3012 esym
= expr
->value
.function
.esym
;
3014 if (is_illegal_recursion (esym
, gfc_current_ns
))
3016 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3017 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3018 " function '%s' is not RECURSIVE",
3019 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3021 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3022 " is not RECURSIVE", esym
->name
, &expr
->where
);
3028 /* Character lengths of use associated functions may contains references to
3029 symbols not referenced from the current program unit otherwise. Make sure
3030 those symbols are marked as referenced. */
3032 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3033 && expr
->value
.function
.esym
->attr
.use_assoc
)
3035 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3038 /* Make sure that the expression has a typespec that works. */
3039 if (expr
->ts
.type
== BT_UNKNOWN
)
3041 if (expr
->symtree
->n
.sym
->result
3042 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3043 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3044 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3051 /************* Subroutine resolution *************/
3054 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3060 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3061 sym
->name
, &c
->loc
);
3062 else if (gfc_do_concurrent_flag
)
3063 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3064 "PURE", sym
->name
, &c
->loc
);
3065 else if (gfc_pure (NULL
))
3066 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3069 if (gfc_implicit_pure (NULL
))
3070 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3075 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3079 if (sym
->attr
.generic
)
3081 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3084 c
->resolved_sym
= s
;
3085 pure_subroutine (c
, s
);
3089 /* TODO: Need to search for elemental references in generic interface. */
3092 if (sym
->attr
.intrinsic
)
3093 return gfc_intrinsic_sub_interface (c
, 0);
3100 resolve_generic_s (gfc_code
*c
)
3105 sym
= c
->symtree
->n
.sym
;
3109 m
= resolve_generic_s0 (c
, sym
);
3112 else if (m
== MATCH_ERROR
)
3116 if (sym
->ns
->parent
== NULL
)
3118 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3122 if (!generic_sym (sym
))
3126 /* Last ditch attempt. See if the reference is to an intrinsic
3127 that possesses a matching interface. 14.1.2.4 */
3128 sym
= c
->symtree
->n
.sym
;
3130 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3132 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3133 sym
->name
, &c
->loc
);
3137 m
= gfc_intrinsic_sub_interface (c
, 0);
3141 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3142 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3148 /* Resolve a subroutine call known to be specific. */
3151 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3155 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3157 if (sym
->attr
.dummy
)
3159 sym
->attr
.proc
= PROC_DUMMY
;
3163 sym
->attr
.proc
= PROC_EXTERNAL
;
3167 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3170 if (sym
->attr
.intrinsic
)
3172 m
= gfc_intrinsic_sub_interface (c
, 1);
3176 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3177 "with an intrinsic", sym
->name
, &c
->loc
);
3185 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3187 c
->resolved_sym
= sym
;
3188 pure_subroutine (c
, sym
);
3195 resolve_specific_s (gfc_code
*c
)
3200 sym
= c
->symtree
->n
.sym
;
3204 m
= resolve_specific_s0 (c
, sym
);
3207 if (m
== MATCH_ERROR
)
3210 if (sym
->ns
->parent
== NULL
)
3213 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3219 sym
= c
->symtree
->n
.sym
;
3220 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3221 sym
->name
, &c
->loc
);
3227 /* Resolve a subroutine call not known to be generic nor specific. */
3230 resolve_unknown_s (gfc_code
*c
)
3234 sym
= c
->symtree
->n
.sym
;
3236 if (sym
->attr
.dummy
)
3238 sym
->attr
.proc
= PROC_DUMMY
;
3242 /* See if we have an intrinsic function reference. */
3244 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3246 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3251 /* The reference is to an external name. */
3254 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3256 c
->resolved_sym
= sym
;
3258 pure_subroutine (c
, sym
);
3264 /* Resolve a subroutine call. Although it was tempting to use the same code
3265 for functions, subroutines and functions are stored differently and this
3266 makes things awkward. */
3269 resolve_call (gfc_code
*c
)
3272 procedure_type ptype
= PROC_INTRINSIC
;
3273 gfc_symbol
*csym
, *sym
;
3274 bool no_formal_args
;
3276 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3278 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3280 gfc_error ("'%s' at %L has a type, which is not consistent with "
3281 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3285 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3288 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3289 sym
= st
? st
->n
.sym
: NULL
;
3290 if (sym
&& csym
!= sym
3291 && sym
->ns
== gfc_current_ns
3292 && sym
->attr
.flavor
== FL_PROCEDURE
3293 && sym
->attr
.contained
)
3296 if (csym
->attr
.generic
)
3297 c
->symtree
->n
.sym
= sym
;
3300 csym
= c
->symtree
->n
.sym
;
3304 /* If this ia a deferred TBP, c->expr1 will be set. */
3305 if (!c
->expr1
&& csym
)
3307 if (csym
->attr
.abstract
)
3309 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3310 csym
->name
, &c
->loc
);
3314 /* Subroutines without the RECURSIVE attribution are not allowed to
3316 if (is_illegal_recursion (csym
, gfc_current_ns
))
3318 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3319 gfc_error ("ENTRY '%s' at %L cannot be called recursively, "
3320 "as subroutine '%s' is not RECURSIVE",
3321 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3323 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, "
3324 "as it is not RECURSIVE", csym
->name
, &c
->loc
);
3330 /* Switch off assumed size checking and do this again for certain kinds
3331 of procedure, once the procedure itself is resolved. */
3332 need_full_assumed_size
++;
3335 ptype
= csym
->attr
.proc
;
3337 no_formal_args
= csym
&& is_external_proc (csym
)
3338 && gfc_sym_get_dummy_args (csym
) == NULL
;
3339 if (!resolve_actual_arglist (c
->ext
.actual
, ptype
, no_formal_args
))
3342 /* Resume assumed_size checking. */
3343 need_full_assumed_size
--;
3345 /* If external, check for usage. */
3346 if (csym
&& is_external_proc (csym
))
3347 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3350 if (c
->resolved_sym
== NULL
)
3352 c
->resolved_isym
= NULL
;
3353 switch (procedure_kind (csym
))
3356 t
= resolve_generic_s (c
);
3359 case PTYPE_SPECIFIC
:
3360 t
= resolve_specific_s (c
);
3364 t
= resolve_unknown_s (c
);
3368 gfc_internal_error ("resolve_subroutine(): bad function type");
3372 /* Some checks of elemental subroutine actual arguments. */
3373 if (!resolve_elemental_actual (NULL
, c
))
3380 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3381 op1->shape and op2->shape are non-NULL return true if their shapes
3382 match. If both op1->shape and op2->shape are non-NULL return false
3383 if their shapes do not match. If either op1->shape or op2->shape is
3384 NULL, return true. */
3387 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3394 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3396 for (i
= 0; i
< op1
->rank
; i
++)
3398 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3400 gfc_error ("Shapes for operands at %L and %L are not conformable",
3401 &op1
->where
, &op2
->where
);
3412 /* Resolve an operator expression node. This can involve replacing the
3413 operation with a user defined function call. */
3416 resolve_operator (gfc_expr
*e
)
3418 gfc_expr
*op1
, *op2
;
3420 bool dual_locus_error
;
3423 /* Resolve all subnodes-- give them types. */
3425 switch (e
->value
.op
.op
)
3428 if (!gfc_resolve_expr (e
->value
.op
.op2
))
3431 /* Fall through... */
3434 case INTRINSIC_UPLUS
:
3435 case INTRINSIC_UMINUS
:
3436 case INTRINSIC_PARENTHESES
:
3437 if (!gfc_resolve_expr (e
->value
.op
.op1
))
3442 /* Typecheck the new node. */
3444 op1
= e
->value
.op
.op1
;
3445 op2
= e
->value
.op
.op2
;
3446 dual_locus_error
= false;
3448 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3449 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3451 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3455 switch (e
->value
.op
.op
)
3457 case INTRINSIC_UPLUS
:
3458 case INTRINSIC_UMINUS
:
3459 if (op1
->ts
.type
== BT_INTEGER
3460 || op1
->ts
.type
== BT_REAL
3461 || op1
->ts
.type
== BT_COMPLEX
)
3467 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3468 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3471 case INTRINSIC_PLUS
:
3472 case INTRINSIC_MINUS
:
3473 case INTRINSIC_TIMES
:
3474 case INTRINSIC_DIVIDE
:
3475 case INTRINSIC_POWER
:
3476 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3478 gfc_type_convert_binary (e
, 1);
3483 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3484 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3485 gfc_typename (&op2
->ts
));
3488 case INTRINSIC_CONCAT
:
3489 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3490 && op1
->ts
.kind
== op2
->ts
.kind
)
3492 e
->ts
.type
= BT_CHARACTER
;
3493 e
->ts
.kind
= op1
->ts
.kind
;
3498 _("Operands of string concatenation operator at %%L are %s/%s"),
3499 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3505 case INTRINSIC_NEQV
:
3506 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3508 e
->ts
.type
= BT_LOGICAL
;
3509 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3510 if (op1
->ts
.kind
< e
->ts
.kind
)
3511 gfc_convert_type (op1
, &e
->ts
, 2);
3512 else if (op2
->ts
.kind
< e
->ts
.kind
)
3513 gfc_convert_type (op2
, &e
->ts
, 2);
3517 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3518 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3519 gfc_typename (&op2
->ts
));
3524 if (op1
->ts
.type
== BT_LOGICAL
)
3526 e
->ts
.type
= BT_LOGICAL
;
3527 e
->ts
.kind
= op1
->ts
.kind
;
3531 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3532 gfc_typename (&op1
->ts
));
3536 case INTRINSIC_GT_OS
:
3538 case INTRINSIC_GE_OS
:
3540 case INTRINSIC_LT_OS
:
3542 case INTRINSIC_LE_OS
:
3543 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3545 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3549 /* Fall through... */
3552 case INTRINSIC_EQ_OS
:
3554 case INTRINSIC_NE_OS
:
3555 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3556 && op1
->ts
.kind
== op2
->ts
.kind
)
3558 e
->ts
.type
= BT_LOGICAL
;
3559 e
->ts
.kind
= gfc_default_logical_kind
;
3563 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3565 gfc_type_convert_binary (e
, 1);
3567 e
->ts
.type
= BT_LOGICAL
;
3568 e
->ts
.kind
= gfc_default_logical_kind
;
3570 if (gfc_option
.warn_compare_reals
)
3572 gfc_intrinsic_op op
= e
->value
.op
.op
;
3574 /* Type conversion has made sure that the types of op1 and op2
3575 agree, so it is only necessary to check the first one. */
3576 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
3577 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
3578 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
3582 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
3583 msg
= "Equality comparison for %s at %L";
3585 msg
= "Inequality comparison for %s at %L";
3587 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
3594 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3596 _("Logicals at %%L must be compared with %s instead of %s"),
3597 (e
->value
.op
.op
== INTRINSIC_EQ
3598 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3599 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3602 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3603 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3604 gfc_typename (&op2
->ts
));
3608 case INTRINSIC_USER
:
3609 if (e
->value
.op
.uop
->op
== NULL
)
3610 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3611 else if (op2
== NULL
)
3612 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3613 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3616 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3617 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3618 gfc_typename (&op2
->ts
));
3619 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3624 case INTRINSIC_PARENTHESES
:
3626 if (e
->ts
.type
== BT_CHARACTER
)
3627 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3631 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3634 /* Deal with arrayness of an operand through an operator. */
3638 switch (e
->value
.op
.op
)
3640 case INTRINSIC_PLUS
:
3641 case INTRINSIC_MINUS
:
3642 case INTRINSIC_TIMES
:
3643 case INTRINSIC_DIVIDE
:
3644 case INTRINSIC_POWER
:
3645 case INTRINSIC_CONCAT
:
3649 case INTRINSIC_NEQV
:
3651 case INTRINSIC_EQ_OS
:
3653 case INTRINSIC_NE_OS
:
3655 case INTRINSIC_GT_OS
:
3657 case INTRINSIC_GE_OS
:
3659 case INTRINSIC_LT_OS
:
3661 case INTRINSIC_LE_OS
:
3663 if (op1
->rank
== 0 && op2
->rank
== 0)
3666 if (op1
->rank
== 0 && op2
->rank
!= 0)
3668 e
->rank
= op2
->rank
;
3670 if (e
->shape
== NULL
)
3671 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3674 if (op1
->rank
!= 0 && op2
->rank
== 0)
3676 e
->rank
= op1
->rank
;
3678 if (e
->shape
== NULL
)
3679 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3682 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3684 if (op1
->rank
== op2
->rank
)
3686 e
->rank
= op1
->rank
;
3687 if (e
->shape
== NULL
)
3689 t
= compare_shapes (op1
, op2
);
3693 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3698 /* Allow higher level expressions to work. */
3701 /* Try user-defined operators, and otherwise throw an error. */
3702 dual_locus_error
= true;
3704 _("Inconsistent ranks for operator at %%L and %%L"));
3711 case INTRINSIC_PARENTHESES
:
3713 case INTRINSIC_UPLUS
:
3714 case INTRINSIC_UMINUS
:
3715 /* Simply copy arrayness attribute */
3716 e
->rank
= op1
->rank
;
3718 if (e
->shape
== NULL
)
3719 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3727 /* Attempt to simplify the expression. */
3730 t
= gfc_simplify_expr (e
, 0);
3731 /* Some calls do not succeed in simplification and return false
3732 even though there is no error; e.g. variable references to
3733 PARAMETER arrays. */
3734 if (!gfc_is_constant_expr (e
))
3742 match m
= gfc_extend_expr (e
);
3745 if (m
== MATCH_ERROR
)
3749 if (dual_locus_error
)
3750 gfc_error (msg
, &op1
->where
, &op2
->where
);
3752 gfc_error (msg
, &e
->where
);
3758 /************** Array resolution subroutines **************/
3761 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3764 /* Compare two integer expressions. */
3767 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3771 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3772 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3775 /* If either of the types isn't INTEGER, we must have
3776 raised an error earlier. */
3778 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3781 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3791 /* Compare an integer expression with an integer. */
3794 compare_bound_int (gfc_expr
*a
, int b
)
3798 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3801 if (a
->ts
.type
!= BT_INTEGER
)
3802 gfc_internal_error ("compare_bound_int(): Bad expression");
3804 i
= mpz_cmp_si (a
->value
.integer
, b
);
3814 /* Compare an integer expression with a mpz_t. */
3817 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3821 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3824 if (a
->ts
.type
!= BT_INTEGER
)
3825 gfc_internal_error ("compare_bound_int(): Bad expression");
3827 i
= mpz_cmp (a
->value
.integer
, b
);
3837 /* Compute the last value of a sequence given by a triplet.
3838 Return 0 if it wasn't able to compute the last value, or if the
3839 sequence if empty, and 1 otherwise. */
3842 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3843 gfc_expr
*stride
, mpz_t last
)
3847 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3848 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3849 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3852 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3853 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3856 if (stride
== NULL
|| compare_bound_int (stride
, 1) == CMP_EQ
)
3858 if (compare_bound (start
, end
) == CMP_GT
)
3860 mpz_set (last
, end
->value
.integer
);
3864 if (compare_bound_int (stride
, 0) == CMP_GT
)
3866 /* Stride is positive */
3867 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3872 /* Stride is negative */
3873 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3878 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3879 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3880 mpz_sub (last
, end
->value
.integer
, rem
);
3887 /* Compare a single dimension of an array reference to the array
3891 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3895 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
3897 gcc_assert (ar
->stride
[i
] == NULL
);
3898 /* This implies [*] as [*:] and [*:3] are not possible. */
3899 if (ar
->start
[i
] == NULL
)
3901 gcc_assert (ar
->end
[i
] == NULL
);
3906 /* Given start, end and stride values, calculate the minimum and
3907 maximum referenced indexes. */
3909 switch (ar
->dimen_type
[i
])
3912 case DIMEN_THIS_IMAGE
:
3917 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3920 gfc_warning ("Array reference at %L is out of bounds "
3921 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3922 mpz_get_si (ar
->start
[i
]->value
.integer
),
3923 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3925 gfc_warning ("Array reference at %L is out of bounds "
3926 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
3927 mpz_get_si (ar
->start
[i
]->value
.integer
),
3928 mpz_get_si (as
->lower
[i
]->value
.integer
),
3932 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3935 gfc_warning ("Array reference at %L is out of bounds "
3936 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3937 mpz_get_si (ar
->start
[i
]->value
.integer
),
3938 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3940 gfc_warning ("Array reference at %L is out of bounds "
3941 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
3942 mpz_get_si (ar
->start
[i
]->value
.integer
),
3943 mpz_get_si (as
->upper
[i
]->value
.integer
),
3952 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3953 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3955 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3957 /* Check for zero stride, which is not allowed. */
3958 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3960 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3964 /* if start == len || (stride > 0 && start < len)
3965 || (stride < 0 && start > len),
3966 then the array section contains at least one element. In this
3967 case, there is an out-of-bounds access if
3968 (start < lower || start > upper). */
3969 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3970 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3971 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3972 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3973 && comp_start_end
== CMP_GT
))
3975 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3977 gfc_warning ("Lower array reference at %L is out of bounds "
3978 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3979 mpz_get_si (AR_START
->value
.integer
),
3980 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3983 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3985 gfc_warning ("Lower array reference at %L is out of bounds "
3986 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3987 mpz_get_si (AR_START
->value
.integer
),
3988 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3993 /* If we can compute the highest index of the array section,
3994 then it also has to be between lower and upper. */
3995 mpz_init (last_value
);
3996 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3999 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4001 gfc_warning ("Upper array reference at %L is out of bounds "
4002 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4003 mpz_get_si (last_value
),
4004 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4005 mpz_clear (last_value
);
4008 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4010 gfc_warning ("Upper array reference at %L is out of bounds "
4011 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4012 mpz_get_si (last_value
),
4013 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4014 mpz_clear (last_value
);
4018 mpz_clear (last_value
);
4026 gfc_internal_error ("check_dimension(): Bad array reference");
4033 /* Compare an array reference with an array specification. */
4036 compare_spec_to_ref (gfc_array_ref
*ar
)
4043 /* TODO: Full array sections are only allowed as actual parameters. */
4044 if (as
->type
== AS_ASSUMED_SIZE
4045 && (/*ar->type == AR_FULL
4046 ||*/ (ar
->type
== AR_SECTION
4047 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4049 gfc_error ("Rightmost upper bound of assumed size array section "
4050 "not specified at %L", &ar
->where
);
4054 if (ar
->type
== AR_FULL
)
4057 if (as
->rank
!= ar
->dimen
)
4059 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4060 &ar
->where
, ar
->dimen
, as
->rank
);
4064 /* ar->codimen == 0 is a local array. */
4065 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4067 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4068 &ar
->where
, ar
->codimen
, as
->corank
);
4072 for (i
= 0; i
< as
->rank
; i
++)
4073 if (!check_dimension (i
, ar
, as
))
4076 /* Local access has no coarray spec. */
4077 if (ar
->codimen
!= 0)
4078 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4080 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4081 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4083 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4084 i
+ 1 - as
->rank
, &ar
->where
);
4087 if (!check_dimension (i
, ar
, as
))
4095 /* Resolve one part of an array index. */
4098 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4099 int force_index_integer_kind
)
4106 if (!gfc_resolve_expr (index
))
4109 if (check_scalar
&& index
->rank
!= 0)
4111 gfc_error ("Array index at %L must be scalar", &index
->where
);
4115 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4117 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4118 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4122 if (index
->ts
.type
== BT_REAL
)
4123 if (!gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4127 if ((index
->ts
.kind
!= gfc_index_integer_kind
4128 && force_index_integer_kind
)
4129 || index
->ts
.type
!= BT_INTEGER
)
4132 ts
.type
= BT_INTEGER
;
4133 ts
.kind
= gfc_index_integer_kind
;
4135 gfc_convert_type_warn (index
, &ts
, 2, 0);
4141 /* Resolve one part of an array index. */
4144 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4146 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4149 /* Resolve a dim argument to an intrinsic function. */
4152 gfc_resolve_dim_arg (gfc_expr
*dim
)
4157 if (!gfc_resolve_expr (dim
))
4162 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4167 if (dim
->ts
.type
!= BT_INTEGER
)
4169 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4173 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4178 ts
.type
= BT_INTEGER
;
4179 ts
.kind
= gfc_index_integer_kind
;
4181 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4187 /* Given an expression that contains array references, update those array
4188 references to point to the right array specifications. While this is
4189 filled in during matching, this information is difficult to save and load
4190 in a module, so we take care of it here.
4192 The idea here is that the original array reference comes from the
4193 base symbol. We traverse the list of reference structures, setting
4194 the stored reference to references. Component references can
4195 provide an additional array specification. */
4198 find_array_spec (gfc_expr
*e
)
4204 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4205 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4207 as
= e
->symtree
->n
.sym
->as
;
4209 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4214 gfc_internal_error ("find_array_spec(): Missing spec");
4221 c
= ref
->u
.c
.component
;
4222 if (c
->attr
.dimension
)
4225 gfc_internal_error ("find_array_spec(): unused as(1)");
4236 gfc_internal_error ("find_array_spec(): unused as(2)");
4240 /* Resolve an array reference. */
4243 resolve_array_ref (gfc_array_ref
*ar
)
4245 int i
, check_scalar
;
4248 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4250 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4252 /* Do not force gfc_index_integer_kind for the start. We can
4253 do fine with any integer kind. This avoids temporary arrays
4254 created for indexing with a vector. */
4255 if (!gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0))
4257 if (!gfc_resolve_index (ar
->end
[i
], check_scalar
))
4259 if (!gfc_resolve_index (ar
->stride
[i
], check_scalar
))
4264 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4268 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4272 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4273 if (e
->expr_type
== EXPR_VARIABLE
4274 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4275 ar
->start
[i
] = gfc_get_parentheses (e
);
4279 gfc_error ("Array index at %L is an array of rank %d",
4280 &ar
->c_where
[i
], e
->rank
);
4284 /* Fill in the upper bound, which may be lower than the
4285 specified one for something like a(2:10:5), which is
4286 identical to a(2:7:5). Only relevant for strides not equal
4287 to one. Don't try a division by zero. */
4288 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4289 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4290 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4291 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4295 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
))
4297 if (ar
->end
[i
] == NULL
)
4300 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4302 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4304 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4305 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4307 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4318 if (ar
->type
== AR_FULL
)
4320 if (ar
->as
->rank
== 0)
4321 ar
->type
= AR_ELEMENT
;
4323 /* Make sure array is the same as array(:,:), this way
4324 we don't need to special case all the time. */
4325 ar
->dimen
= ar
->as
->rank
;
4326 for (i
= 0; i
< ar
->dimen
; i
++)
4328 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4330 gcc_assert (ar
->start
[i
] == NULL
);
4331 gcc_assert (ar
->end
[i
] == NULL
);
4332 gcc_assert (ar
->stride
[i
] == NULL
);
4336 /* If the reference type is unknown, figure out what kind it is. */
4338 if (ar
->type
== AR_UNKNOWN
)
4340 ar
->type
= AR_ELEMENT
;
4341 for (i
= 0; i
< ar
->dimen
; i
++)
4342 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4343 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4345 ar
->type
= AR_SECTION
;
4350 if (!ar
->as
->cray_pointee
&& !compare_spec_to_ref (ar
))
4353 if (ar
->as
->corank
&& ar
->codimen
== 0)
4356 ar
->codimen
= ar
->as
->corank
;
4357 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4358 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4366 resolve_substring (gfc_ref
*ref
)
4368 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4370 if (ref
->u
.ss
.start
!= NULL
)
4372 if (!gfc_resolve_expr (ref
->u
.ss
.start
))
4375 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4377 gfc_error ("Substring start index at %L must be of type INTEGER",
4378 &ref
->u
.ss
.start
->where
);
4382 if (ref
->u
.ss
.start
->rank
!= 0)
4384 gfc_error ("Substring start index at %L must be scalar",
4385 &ref
->u
.ss
.start
->where
);
4389 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4390 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4391 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4393 gfc_error ("Substring start index at %L is less than one",
4394 &ref
->u
.ss
.start
->where
);
4399 if (ref
->u
.ss
.end
!= NULL
)
4401 if (!gfc_resolve_expr (ref
->u
.ss
.end
))
4404 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4406 gfc_error ("Substring end index at %L must be of type INTEGER",
4407 &ref
->u
.ss
.end
->where
);
4411 if (ref
->u
.ss
.end
->rank
!= 0)
4413 gfc_error ("Substring end index at %L must be scalar",
4414 &ref
->u
.ss
.end
->where
);
4418 if (ref
->u
.ss
.length
!= NULL
4419 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4420 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4421 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4423 gfc_error ("Substring end index at %L exceeds the string length",
4424 &ref
->u
.ss
.start
->where
);
4428 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4429 gfc_integer_kinds
[k
].huge
) == CMP_GT
4430 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4431 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4433 gfc_error ("Substring end index at %L is too large",
4434 &ref
->u
.ss
.end
->where
);
4443 /* This function supplies missing substring charlens. */
4446 gfc_resolve_substring_charlen (gfc_expr
*e
)
4449 gfc_expr
*start
, *end
;
4451 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4452 if (char_ref
->type
== REF_SUBSTRING
)
4458 gcc_assert (char_ref
->next
== NULL
);
4462 if (e
->ts
.u
.cl
->length
)
4463 gfc_free_expr (e
->ts
.u
.cl
->length
);
4464 else if (e
->expr_type
== EXPR_VARIABLE
4465 && e
->symtree
->n
.sym
->attr
.dummy
)
4469 e
->ts
.type
= BT_CHARACTER
;
4470 e
->ts
.kind
= gfc_default_character_kind
;
4473 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4475 if (char_ref
->u
.ss
.start
)
4476 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4478 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4480 if (char_ref
->u
.ss
.end
)
4481 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4482 else if (e
->expr_type
== EXPR_VARIABLE
)
4483 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4489 gfc_free_expr (start
);
4490 gfc_free_expr (end
);
4494 /* Length = (end - start +1). */
4495 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4496 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4497 gfc_get_int_expr (gfc_default_integer_kind
,
4500 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4501 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4503 /* Make sure that the length is simplified. */
4504 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4505 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4509 /* Resolve subtype references. */
4512 resolve_ref (gfc_expr
*expr
)
4514 int current_part_dimension
, n_components
, seen_part_dimension
;
4517 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4518 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4520 find_array_spec (expr
);
4524 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4528 if (!resolve_array_ref (&ref
->u
.ar
))
4536 if (!resolve_substring (ref
))
4541 /* Check constraints on part references. */
4543 current_part_dimension
= 0;
4544 seen_part_dimension
= 0;
4547 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4552 switch (ref
->u
.ar
.type
)
4555 /* Coarray scalar. */
4556 if (ref
->u
.ar
.as
->rank
== 0)
4558 current_part_dimension
= 0;
4563 current_part_dimension
= 1;
4567 current_part_dimension
= 0;
4571 gfc_internal_error ("resolve_ref(): Bad array reference");
4577 if (current_part_dimension
|| seen_part_dimension
)
4580 if (ref
->u
.c
.component
->attr
.pointer
4581 || ref
->u
.c
.component
->attr
.proc_pointer
4582 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4583 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4585 gfc_error ("Component to the right of a part reference "
4586 "with nonzero rank must not have the POINTER "
4587 "attribute at %L", &expr
->where
);
4590 else if (ref
->u
.c
.component
->attr
.allocatable
4591 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4592 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4595 gfc_error ("Component to the right of a part reference "
4596 "with nonzero rank must not have the ALLOCATABLE "
4597 "attribute at %L", &expr
->where
);
4609 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4610 || ref
->next
== NULL
)
4611 && current_part_dimension
4612 && seen_part_dimension
)
4614 gfc_error ("Two or more part references with nonzero rank must "
4615 "not be specified at %L", &expr
->where
);
4619 if (ref
->type
== REF_COMPONENT
)
4621 if (current_part_dimension
)
4622 seen_part_dimension
= 1;
4624 /* reset to make sure */
4625 current_part_dimension
= 0;
4633 /* Given an expression, determine its shape. This is easier than it sounds.
4634 Leaves the shape array NULL if it is not possible to determine the shape. */
4637 expression_shape (gfc_expr
*e
)
4639 mpz_t array
[GFC_MAX_DIMENSIONS
];
4642 if (e
->rank
<= 0 || e
->shape
!= NULL
)
4645 for (i
= 0; i
< e
->rank
; i
++)
4646 if (!gfc_array_dimen_size (e
, i
, &array
[i
]))
4649 e
->shape
= gfc_get_shape (e
->rank
);
4651 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4656 for (i
--; i
>= 0; i
--)
4657 mpz_clear (array
[i
]);
4661 /* Given a variable expression node, compute the rank of the expression by
4662 examining the base symbol and any reference structures it may have. */
4665 expression_rank (gfc_expr
*e
)
4670 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4671 could lead to serious confusion... */
4672 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4676 if (e
->expr_type
== EXPR_ARRAY
)
4678 /* Constructors can have a rank different from one via RESHAPE(). */
4680 if (e
->symtree
== NULL
)
4686 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4687 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4693 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4695 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4696 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4697 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4699 if (ref
->type
!= REF_ARRAY
)
4702 if (ref
->u
.ar
.type
== AR_FULL
)
4704 rank
= ref
->u
.ar
.as
->rank
;
4708 if (ref
->u
.ar
.type
== AR_SECTION
)
4710 /* Figure out the rank of the section. */
4712 gfc_internal_error ("expression_rank(): Two array specs");
4714 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4715 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4716 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4726 expression_shape (e
);
4730 /* Resolve a variable expression. */
4733 resolve_variable (gfc_expr
*e
)
4740 if (e
->symtree
== NULL
)
4742 sym
= e
->symtree
->n
.sym
;
4744 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*)
4745 as ts.type is set to BT_ASSUMED in resolve_symbol. */
4746 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
4748 if (!actual_arg
|| inquiry_argument
)
4750 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only "
4751 "be used as actual argument", sym
->name
, &e
->where
);
4755 /* TS 29113, 407b. */
4756 else if (e
->ts
.type
== BT_ASSUMED
)
4760 gfc_error ("Assumed-type variable %s at %L may only be used "
4761 "as actual argument", sym
->name
, &e
->where
);
4764 else if (inquiry_argument
&& !first_actual_arg
)
4766 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4767 for all inquiry functions in resolve_function; the reason is
4768 that the function-name resolution happens too late in that
4770 gfc_error ("Assumed-type variable %s at %L as actual argument to "
4771 "an inquiry function shall be the first argument",
4772 sym
->name
, &e
->where
);
4776 /* TS 29113, C535b. */
4777 else if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4778 && CLASS_DATA (sym
)->as
4779 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4780 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4781 && sym
->as
->type
== AS_ASSUMED_RANK
))
4785 gfc_error ("Assumed-rank variable %s at %L may only be used as "
4786 "actual argument", sym
->name
, &e
->where
);
4789 else if (inquiry_argument
&& !first_actual_arg
)
4791 /* FIXME: It doesn't work reliably as inquiry_argument is not set
4792 for all inquiry functions in resolve_function; the reason is
4793 that the function-name resolution happens too late in that
4795 gfc_error ("Assumed-rank variable %s at %L as actual argument "
4796 "to an inquiry function shall be the first argument",
4797 sym
->name
, &e
->where
);
4802 if ((sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
)) && e
->ref
4803 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4804 && e
->ref
->next
== NULL
))
4806 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have "
4807 "a subobject reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4810 /* TS 29113, 407b. */
4811 else if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
4812 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4813 && e
->ref
->next
== NULL
))
4815 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
4816 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4820 /* TS 29113, C535b. */
4821 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
4822 && CLASS_DATA (sym
)->as
4823 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
4824 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
4825 && sym
->as
->type
== AS_ASSUMED_RANK
))
4827 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
4828 && e
->ref
->next
== NULL
))
4830 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
4831 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
4836 /* If this is an associate-name, it may be parsed with an array reference
4837 in error even though the target is scalar. Fail directly in this case.
4838 TODO Understand why class scalar expressions must be excluded. */
4839 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
4841 if (sym
->ts
.type
== BT_CLASS
)
4842 gfc_fix_class_refs (e
);
4843 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4847 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
4848 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
4850 /* On the other hand, the parser may not have known this is an array;
4851 in this case, we have to add a FULL reference. */
4852 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4854 e
->ref
= gfc_get_ref ();
4855 e
->ref
->type
= REF_ARRAY
;
4856 e
->ref
->u
.ar
.type
= AR_FULL
;
4857 e
->ref
->u
.ar
.dimen
= 0;
4860 if (e
->ref
&& !resolve_ref (e
))
4863 if (sym
->attr
.flavor
== FL_PROCEDURE
4864 && (!sym
->attr
.function
4865 || (sym
->attr
.function
&& sym
->result
4866 && sym
->result
->attr
.proc_pointer
4867 && !sym
->result
->attr
.function
)))
4869 e
->ts
.type
= BT_PROCEDURE
;
4870 goto resolve_procedure
;
4873 if (sym
->ts
.type
!= BT_UNKNOWN
)
4874 gfc_variable_attr (e
, &e
->ts
);
4877 /* Must be a simple variable reference. */
4878 if (!gfc_set_default_type (sym
, 1, sym
->ns
))
4883 if (check_assumed_size_reference (sym
, e
))
4886 /* Deal with forward references to entries during resolve_code, to
4887 satisfy, at least partially, 12.5.2.5. */
4888 if (gfc_current_ns
->entries
4889 && current_entry_id
== sym
->entry_id
4892 && cs_base
->current
->op
!= EXEC_ENTRY
)
4894 gfc_entry_list
*entry
;
4895 gfc_formal_arglist
*formal
;
4897 bool seen
, saved_specification_expr
;
4899 /* If the symbol is a dummy... */
4900 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4902 entry
= gfc_current_ns
->entries
;
4905 /* ...test if the symbol is a parameter of previous entries. */
4906 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4907 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4909 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4916 /* If it has not been seen as a dummy, this is an error. */
4919 if (specification_expr
)
4920 gfc_error ("Variable '%s', used in a specification expression"
4921 ", is referenced at %L before the ENTRY statement "
4922 "in which it is a parameter",
4923 sym
->name
, &cs_base
->current
->loc
);
4925 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4926 "statement in which it is a parameter",
4927 sym
->name
, &cs_base
->current
->loc
);
4932 /* Now do the same check on the specification expressions. */
4933 saved_specification_expr
= specification_expr
;
4934 specification_expr
= true;
4935 if (sym
->ts
.type
== BT_CHARACTER
4936 && !gfc_resolve_expr (sym
->ts
.u
.cl
->length
))
4940 for (n
= 0; n
< sym
->as
->rank
; n
++)
4942 if (!gfc_resolve_expr (sym
->as
->lower
[n
]))
4944 if (!gfc_resolve_expr (sym
->as
->upper
[n
]))
4947 specification_expr
= saved_specification_expr
;
4950 /* Update the symbol's entry level. */
4951 sym
->entry_id
= current_entry_id
+ 1;
4954 /* If a symbol has been host_associated mark it. This is used latter,
4955 to identify if aliasing is possible via host association. */
4956 if (sym
->attr
.flavor
== FL_VARIABLE
4957 && gfc_current_ns
->parent
4958 && (gfc_current_ns
->parent
== sym
->ns
4959 || (gfc_current_ns
->parent
->parent
4960 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
4961 sym
->attr
.host_assoc
= 1;
4964 if (t
&& !resolve_procedure_expression (e
))
4967 /* F2008, C617 and C1229. */
4968 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
4969 && gfc_is_coindexed (e
))
4971 gfc_ref
*ref
, *ref2
= NULL
;
4973 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4975 if (ref
->type
== REF_COMPONENT
)
4977 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
4981 for ( ; ref
; ref
= ref
->next
)
4982 if (ref
->type
== REF_COMPONENT
)
4985 /* Expression itself is not coindexed object. */
4986 if (ref
&& e
->ts
.type
== BT_CLASS
)
4988 gfc_error ("Polymorphic subobject of coindexed object at %L",
4993 /* Expression itself is coindexed object. */
4997 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
4998 for ( ; c
; c
= c
->next
)
4999 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5001 gfc_error ("Coindexed object with polymorphic allocatable "
5002 "subcomponent at %L", &e
->where
);
5013 /* Checks to see that the correct symbol has been host associated.
5014 The only situation where this arises is that in which a twice
5015 contained function is parsed after the host association is made.
5016 Therefore, on detecting this, change the symbol in the expression
5017 and convert the array reference into an actual arglist if the old
5018 symbol is a variable. */
5020 check_host_association (gfc_expr
*e
)
5022 gfc_symbol
*sym
, *old_sym
;
5026 gfc_actual_arglist
*arg
, *tail
= NULL
;
5027 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5029 /* If the expression is the result of substitution in
5030 interface.c(gfc_extend_expr) because there is no way in
5031 which the host association can be wrong. */
5032 if (e
->symtree
== NULL
5033 || e
->symtree
->n
.sym
== NULL
5034 || e
->user_operator
)
5037 old_sym
= e
->symtree
->n
.sym
;
5039 if (gfc_current_ns
->parent
5040 && old_sym
->ns
!= gfc_current_ns
)
5042 /* Use the 'USE' name so that renamed module symbols are
5043 correctly handled. */
5044 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5046 if (sym
&& old_sym
!= sym
5047 && sym
->ts
.type
== old_sym
->ts
.type
5048 && sym
->attr
.flavor
== FL_PROCEDURE
5049 && sym
->attr
.contained
)
5051 /* Clear the shape, since it might not be valid. */
5052 gfc_free_shape (&e
->shape
, e
->rank
);
5054 /* Give the expression the right symtree! */
5055 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5056 gcc_assert (st
!= NULL
);
5058 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5059 || e
->expr_type
== EXPR_FUNCTION
)
5061 /* Original was function so point to the new symbol, since
5062 the actual argument list is already attached to the
5064 e
->value
.function
.esym
= NULL
;
5069 /* Original was variable so convert array references into
5070 an actual arglist. This does not need any checking now
5071 since resolve_function will take care of it. */
5072 e
->value
.function
.actual
= NULL
;
5073 e
->expr_type
= EXPR_FUNCTION
;
5076 /* Ambiguity will not arise if the array reference is not
5077 the last reference. */
5078 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5079 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5082 gcc_assert (ref
->type
== REF_ARRAY
);
5084 /* Grab the start expressions from the array ref and
5085 copy them into actual arguments. */
5086 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5088 arg
= gfc_get_actual_arglist ();
5089 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5090 if (e
->value
.function
.actual
== NULL
)
5091 tail
= e
->value
.function
.actual
= arg
;
5099 /* Dump the reference list and set the rank. */
5100 gfc_free_ref_list (e
->ref
);
5102 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5105 gfc_resolve_expr (e
);
5109 /* This might have changed! */
5110 return e
->expr_type
== EXPR_FUNCTION
;
5115 gfc_resolve_character_operator (gfc_expr
*e
)
5117 gfc_expr
*op1
= e
->value
.op
.op1
;
5118 gfc_expr
*op2
= e
->value
.op
.op2
;
5119 gfc_expr
*e1
= NULL
;
5120 gfc_expr
*e2
= NULL
;
5122 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5124 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5125 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5126 else if (op1
->expr_type
== EXPR_CONSTANT
)
5127 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5128 op1
->value
.character
.length
);
5130 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5131 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5132 else if (op2
->expr_type
== EXPR_CONSTANT
)
5133 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5134 op2
->value
.character
.length
);
5136 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5146 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5147 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5148 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5149 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5150 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5156 /* Ensure that an character expression has a charlen and, if possible, a
5157 length expression. */
5160 fixup_charlen (gfc_expr
*e
)
5162 /* The cases fall through so that changes in expression type and the need
5163 for multiple fixes are picked up. In all circumstances, a charlen should
5164 be available for the middle end to hang a backend_decl on. */
5165 switch (e
->expr_type
)
5168 gfc_resolve_character_operator (e
);
5171 if (e
->expr_type
== EXPR_ARRAY
)
5172 gfc_resolve_character_array_constructor (e
);
5174 case EXPR_SUBSTRING
:
5175 if (!e
->ts
.u
.cl
&& e
->ref
)
5176 gfc_resolve_substring_charlen (e
);
5180 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5187 /* Update an actual argument to include the passed-object for type-bound
5188 procedures at the right position. */
5190 static gfc_actual_arglist
*
5191 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5194 gcc_assert (argpos
> 0);
5198 gfc_actual_arglist
* result
;
5200 result
= gfc_get_actual_arglist ();
5204 result
->name
= name
;
5210 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5212 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5217 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5220 extract_compcall_passed_object (gfc_expr
* e
)
5224 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5226 if (e
->value
.compcall
.base_object
)
5227 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5230 po
= gfc_get_expr ();
5231 po
->expr_type
= EXPR_VARIABLE
;
5232 po
->symtree
= e
->symtree
;
5233 po
->ref
= gfc_copy_ref (e
->ref
);
5234 po
->where
= e
->where
;
5237 if (!gfc_resolve_expr (po
))
5244 /* Update the arglist of an EXPR_COMPCALL expression to include the
5248 update_compcall_arglist (gfc_expr
* e
)
5251 gfc_typebound_proc
* tbp
;
5253 tbp
= e
->value
.compcall
.tbp
;
5258 po
= extract_compcall_passed_object (e
);
5262 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5268 gcc_assert (tbp
->pass_arg_num
> 0);
5269 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5277 /* Extract the passed object from a PPC call (a copy of it). */
5280 extract_ppc_passed_object (gfc_expr
*e
)
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
;
5291 /* Remove PPC reference. */
5293 while ((*ref
)->next
)
5294 ref
= &(*ref
)->next
;
5295 gfc_free_ref_list (*ref
);
5298 if (!gfc_resolve_expr (po
))
5305 /* Update the actual arglist of a procedure pointer component to include the
5309 update_ppc_arglist (gfc_expr
* e
)
5313 gfc_typebound_proc
* tb
;
5315 ppc
= gfc_get_proc_ptr_comp (e
);
5323 else if (tb
->nopass
)
5326 po
= extract_ppc_passed_object (e
);
5333 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5338 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5340 gfc_error ("Base object for procedure-pointer component call at %L is of"
5341 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5345 gcc_assert (tb
->pass_arg_num
> 0);
5346 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5354 /* Check that the object a TBP is called on is valid, i.e. it must not be
5355 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5358 check_typebound_baseobject (gfc_expr
* e
)
5361 bool return_value
= false;
5363 base
= extract_compcall_passed_object (e
);
5367 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5369 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5373 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5375 gfc_error ("Base object for type-bound procedure call at %L is of"
5376 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5380 /* F08:C1230. If the procedure called is NOPASS,
5381 the base object must be scalar. */
5382 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5384 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5385 " be scalar", &e
->where
);
5389 return_value
= true;
5392 gfc_free_expr (base
);
5393 return return_value
;
5397 /* Resolve a call to a type-bound procedure, either function or subroutine,
5398 statically from the data in an EXPR_COMPCALL expression. The adapted
5399 arglist and the target-procedure symtree are returned. */
5402 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5403 gfc_actual_arglist
** actual
)
5405 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5406 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5408 /* Update the actual arglist for PASS. */
5409 if (!update_compcall_arglist (e
))
5412 *actual
= e
->value
.compcall
.actual
;
5413 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5415 gfc_free_ref_list (e
->ref
);
5417 e
->value
.compcall
.actual
= NULL
;
5419 /* If we find a deferred typebound procedure, check for derived types
5420 that an overriding typebound procedure has not been missed. */
5421 if (e
->value
.compcall
.name
5422 && !e
->value
.compcall
.tbp
->non_overridable
5423 && e
->value
.compcall
.base_object
5424 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5427 gfc_symbol
*derived
;
5429 /* Use the derived type of the base_object. */
5430 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5433 /* If necessary, go through the inheritance chain. */
5434 while (!st
&& derived
)
5436 /* Look for the typebound procedure 'name'. */
5437 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5438 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5439 e
->value
.compcall
.name
);
5441 derived
= gfc_get_derived_super_type (derived
);
5444 /* Now find the specific name in the derived type namespace. */
5445 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5446 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5447 derived
->ns
, 1, &st
);
5455 /* Get the ultimate declared type from an expression. In addition,
5456 return the last class/derived type reference and the copy of the
5457 reference list. If check_types is set true, derived types are
5458 identified as well as class references. */
5460 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5461 gfc_expr
*e
, bool check_types
)
5463 gfc_symbol
*declared
;
5470 *new_ref
= gfc_copy_ref (e
->ref
);
5472 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5474 if (ref
->type
!= REF_COMPONENT
)
5477 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5478 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5479 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5481 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5487 if (declared
== NULL
)
5488 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5494 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5495 which of the specific bindings (if any) matches the arglist and transform
5496 the expression into a call of that binding. */
5499 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5501 gfc_typebound_proc
* genproc
;
5502 const char* genname
;
5504 gfc_symbol
*derived
;
5506 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5507 genname
= e
->value
.compcall
.name
;
5508 genproc
= e
->value
.compcall
.tbp
;
5510 if (!genproc
->is_generic
)
5513 /* Try the bindings on this type and in the inheritance hierarchy. */
5514 for (; genproc
; genproc
= genproc
->overridden
)
5518 gcc_assert (genproc
->is_generic
);
5519 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5522 gfc_actual_arglist
* args
;
5525 gcc_assert (g
->specific
);
5527 if (g
->specific
->error
)
5530 target
= g
->specific
->u
.specific
->n
.sym
;
5532 /* Get the right arglist by handling PASS/NOPASS. */
5533 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5534 if (!g
->specific
->nopass
)
5537 po
= extract_compcall_passed_object (e
);
5540 gfc_free_actual_arglist (args
);
5544 gcc_assert (g
->specific
->pass_arg_num
> 0);
5545 gcc_assert (!g
->specific
->error
);
5546 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5547 g
->specific
->pass_arg
);
5549 resolve_actual_arglist (args
, target
->attr
.proc
,
5550 is_external_proc (target
)
5551 && gfc_sym_get_dummy_args (target
) == NULL
);
5553 /* Check if this arglist matches the formal. */
5554 matches
= gfc_arglist_matches_symbol (&args
, target
);
5556 /* Clean up and break out of the loop if we've found it. */
5557 gfc_free_actual_arglist (args
);
5560 e
->value
.compcall
.tbp
= g
->specific
;
5561 genname
= g
->specific_st
->name
;
5562 /* Pass along the name for CLASS methods, where the vtab
5563 procedure pointer component has to be referenced. */
5571 /* Nothing matching found! */
5572 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5573 " '%s' at %L", genname
, &e
->where
);
5577 /* Make sure that we have the right specific instance for the name. */
5578 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5580 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5582 e
->value
.compcall
.tbp
= st
->n
.tb
;
5588 /* Resolve a call to a type-bound subroutine. */
5591 resolve_typebound_call (gfc_code
* c
, const char **name
)
5593 gfc_actual_arglist
* newactual
;
5594 gfc_symtree
* target
;
5596 /* Check that's really a SUBROUTINE. */
5597 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5599 gfc_error ("'%s' at %L should be a SUBROUTINE",
5600 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5604 if (!check_typebound_baseobject (c
->expr1
))
5607 /* Pass along the name for CLASS methods, where the vtab
5608 procedure pointer component has to be referenced. */
5610 *name
= c
->expr1
->value
.compcall
.name
;
5612 if (!resolve_typebound_generic_call (c
->expr1
, name
))
5615 /* Transform into an ordinary EXEC_CALL for now. */
5617 if (!resolve_typebound_static (c
->expr1
, &target
, &newactual
))
5620 c
->ext
.actual
= newactual
;
5621 c
->symtree
= target
;
5622 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5624 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5626 gfc_free_expr (c
->expr1
);
5627 c
->expr1
= gfc_get_expr ();
5628 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5629 c
->expr1
->symtree
= target
;
5630 c
->expr1
->where
= c
->loc
;
5632 return resolve_call (c
);
5636 /* Resolve a component-call expression. */
5638 resolve_compcall (gfc_expr
* e
, const char **name
)
5640 gfc_actual_arglist
* newactual
;
5641 gfc_symtree
* target
;
5643 /* Check that's really a FUNCTION. */
5644 if (!e
->value
.compcall
.tbp
->function
)
5646 gfc_error ("'%s' at %L should be a FUNCTION",
5647 e
->value
.compcall
.name
, &e
->where
);
5651 /* These must not be assign-calls! */
5652 gcc_assert (!e
->value
.compcall
.assign
);
5654 if (!check_typebound_baseobject (e
))
5657 /* Pass along the name for CLASS methods, where the vtab
5658 procedure pointer component has to be referenced. */
5660 *name
= e
->value
.compcall
.name
;
5662 if (!resolve_typebound_generic_call (e
, name
))
5664 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5666 /* Take the rank from the function's symbol. */
5667 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5668 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5670 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5671 arglist to the TBP's binding target. */
5673 if (!resolve_typebound_static (e
, &target
, &newactual
))
5676 e
->value
.function
.actual
= newactual
;
5677 e
->value
.function
.name
= NULL
;
5678 e
->value
.function
.esym
= target
->n
.sym
;
5679 e
->value
.function
.isym
= NULL
;
5680 e
->symtree
= target
;
5681 e
->ts
= target
->n
.sym
->ts
;
5682 e
->expr_type
= EXPR_FUNCTION
;
5684 /* Resolution is not necessary if this is a class subroutine; this
5685 function only has to identify the specific proc. Resolution of
5686 the call will be done next in resolve_typebound_call. */
5687 return gfc_resolve_expr (e
);
5691 static bool resolve_fl_derived (gfc_symbol
*sym
);
5694 /* Resolve a typebound function, or 'method'. First separate all
5695 the non-CLASS references by calling resolve_compcall directly. */
5698 resolve_typebound_function (gfc_expr
* e
)
5700 gfc_symbol
*declared
;
5712 /* Deal with typebound operators for CLASS objects. */
5713 expr
= e
->value
.compcall
.base_object
;
5714 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
5715 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5717 /* If the base_object is not a variable, the corresponding actual
5718 argument expression must be stored in e->base_expression so
5719 that the corresponding tree temporary can be used as the base
5720 object in gfc_conv_procedure_call. */
5721 if (expr
->expr_type
!= EXPR_VARIABLE
)
5723 gfc_actual_arglist
*args
;
5725 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
5727 if (expr
== args
->expr
)
5732 /* Since the typebound operators are generic, we have to ensure
5733 that any delays in resolution are corrected and that the vtab
5736 declared
= ts
.u
.derived
;
5737 c
= gfc_find_component (declared
, "_vptr", true, true);
5738 if (c
->ts
.u
.derived
== NULL
)
5739 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5741 if (!resolve_compcall (e
, &name
))
5744 /* Use the generic name if it is there. */
5745 name
= name
? name
: e
->value
.function
.esym
->name
;
5746 e
->symtree
= expr
->symtree
;
5747 e
->ref
= gfc_copy_ref (expr
->ref
);
5748 get_declared_from_expr (&class_ref
, NULL
, e
, false);
5750 /* Trim away the extraneous references that emerge from nested
5751 use of interface.c (extend_expr). */
5752 if (class_ref
&& class_ref
->next
)
5754 gfc_free_ref_list (class_ref
->next
);
5755 class_ref
->next
= NULL
;
5757 else if (e
->ref
&& !class_ref
)
5759 gfc_free_ref_list (e
->ref
);
5763 gfc_add_vptr_component (e
);
5764 gfc_add_component_ref (e
, name
);
5765 e
->value
.function
.esym
= NULL
;
5766 if (expr
->expr_type
!= EXPR_VARIABLE
)
5767 e
->base_expr
= expr
;
5772 return resolve_compcall (e
, NULL
);
5774 if (!resolve_ref (e
))
5777 /* Get the CLASS declared type. */
5778 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
5780 if (!resolve_fl_derived (declared
))
5783 /* Weed out cases of the ultimate component being a derived type. */
5784 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5785 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5787 gfc_free_ref_list (new_ref
);
5788 return resolve_compcall (e
, NULL
);
5791 c
= gfc_find_component (declared
, "_data", true, true);
5792 declared
= c
->ts
.u
.derived
;
5794 /* Treat the call as if it is a typebound procedure, in order to roll
5795 out the correct name for the specific function. */
5796 if (!resolve_compcall (e
, &name
))
5798 gfc_free_ref_list (new_ref
);
5805 /* Convert the expression to a procedure pointer component call. */
5806 e
->value
.function
.esym
= NULL
;
5812 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5813 gfc_add_vptr_component (e
);
5814 gfc_add_component_ref (e
, name
);
5816 /* Recover the typespec for the expression. This is really only
5817 necessary for generic procedures, where the additional call
5818 to gfc_add_component_ref seems to throw the collection of the
5819 correct typespec. */
5823 gfc_free_ref_list (new_ref
);
5828 /* Resolve a typebound subroutine, or 'method'. First separate all
5829 the non-CLASS references by calling resolve_typebound_call
5833 resolve_typebound_subroutine (gfc_code
*code
)
5835 gfc_symbol
*declared
;
5845 st
= code
->expr1
->symtree
;
5847 /* Deal with typebound operators for CLASS objects. */
5848 expr
= code
->expr1
->value
.compcall
.base_object
;
5849 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
5850 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5852 /* If the base_object is not a variable, the corresponding actual
5853 argument expression must be stored in e->base_expression so
5854 that the corresponding tree temporary can be used as the base
5855 object in gfc_conv_procedure_call. */
5856 if (expr
->expr_type
!= EXPR_VARIABLE
)
5858 gfc_actual_arglist
*args
;
5860 args
= code
->expr1
->value
.function
.actual
;
5861 for (; args
; args
= args
->next
)
5862 if (expr
== args
->expr
)
5866 /* Since the typebound operators are generic, we have to ensure
5867 that any delays in resolution are corrected and that the vtab
5869 declared
= expr
->ts
.u
.derived
;
5870 c
= gfc_find_component (declared
, "_vptr", true, true);
5871 if (c
->ts
.u
.derived
== NULL
)
5872 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5874 if (!resolve_typebound_call (code
, &name
))
5877 /* Use the generic name if it is there. */
5878 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5879 code
->expr1
->symtree
= expr
->symtree
;
5880 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5882 /* Trim away the extraneous references that emerge from nested
5883 use of interface.c (extend_expr). */
5884 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
5885 if (class_ref
&& class_ref
->next
)
5887 gfc_free_ref_list (class_ref
->next
);
5888 class_ref
->next
= NULL
;
5890 else if (code
->expr1
->ref
&& !class_ref
)
5892 gfc_free_ref_list (code
->expr1
->ref
);
5893 code
->expr1
->ref
= NULL
;
5896 /* Now use the procedure in the vtable. */
5897 gfc_add_vptr_component (code
->expr1
);
5898 gfc_add_component_ref (code
->expr1
, name
);
5899 code
->expr1
->value
.function
.esym
= NULL
;
5900 if (expr
->expr_type
!= EXPR_VARIABLE
)
5901 code
->expr1
->base_expr
= expr
;
5906 return resolve_typebound_call (code
, NULL
);
5908 if (!resolve_ref (code
->expr1
))
5911 /* Get the CLASS declared type. */
5912 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
5914 /* Weed out cases of the ultimate component being a derived type. */
5915 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5916 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5918 gfc_free_ref_list (new_ref
);
5919 return resolve_typebound_call (code
, NULL
);
5922 if (!resolve_typebound_call (code
, &name
))
5924 gfc_free_ref_list (new_ref
);
5927 ts
= code
->expr1
->ts
;
5931 /* Convert the expression to a procedure pointer component call. */
5932 code
->expr1
->value
.function
.esym
= NULL
;
5933 code
->expr1
->symtree
= st
;
5936 code
->expr1
->ref
= new_ref
;
5938 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5939 gfc_add_vptr_component (code
->expr1
);
5940 gfc_add_component_ref (code
->expr1
, name
);
5942 /* Recover the typespec for the expression. This is really only
5943 necessary for generic procedures, where the additional call
5944 to gfc_add_component_ref seems to throw the collection of the
5945 correct typespec. */
5946 code
->expr1
->ts
= ts
;
5949 gfc_free_ref_list (new_ref
);
5955 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5958 resolve_ppc_call (gfc_code
* c
)
5960 gfc_component
*comp
;
5962 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
5963 gcc_assert (comp
!= NULL
);
5965 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5966 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5968 if (!comp
->attr
.subroutine
)
5969 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5971 if (!resolve_ref (c
->expr1
))
5974 if (!update_ppc_arglist (c
->expr1
))
5977 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5979 if (!resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5980 !(comp
->ts
.interface
5981 && comp
->ts
.interface
->formal
)))
5984 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5990 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5993 resolve_expr_ppc (gfc_expr
* e
)
5995 gfc_component
*comp
;
5997 comp
= gfc_get_proc_ptr_comp (e
);
5998 gcc_assert (comp
!= NULL
);
6000 /* Convert to EXPR_FUNCTION. */
6001 e
->expr_type
= EXPR_FUNCTION
;
6002 e
->value
.function
.isym
= NULL
;
6003 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6005 if (comp
->as
!= NULL
)
6006 e
->rank
= comp
->as
->rank
;
6008 if (!comp
->attr
.function
)
6009 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6011 if (!resolve_ref (e
))
6014 if (!resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6015 !(comp
->ts
.interface
6016 && comp
->ts
.interface
->formal
)))
6019 if (!update_ppc_arglist (e
))
6022 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6029 gfc_is_expandable_expr (gfc_expr
*e
)
6031 gfc_constructor
*con
;
6033 if (e
->expr_type
== EXPR_ARRAY
)
6035 /* Traverse the constructor looking for variables that are flavor
6036 parameter. Parameters must be expanded since they are fully used at
6038 con
= gfc_constructor_first (e
->value
.constructor
);
6039 for (; con
; con
= gfc_constructor_next (con
))
6041 if (con
->expr
->expr_type
== EXPR_VARIABLE
6042 && con
->expr
->symtree
6043 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6044 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6046 if (con
->expr
->expr_type
== EXPR_ARRAY
6047 && gfc_is_expandable_expr (con
->expr
))
6055 /* Resolve an expression. That is, make sure that types of operands agree
6056 with their operators, intrinsic operators are converted to function calls
6057 for overloaded types and unresolved function references are resolved. */
6060 gfc_resolve_expr (gfc_expr
*e
)
6063 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6068 /* inquiry_argument only applies to variables. */
6069 inquiry_save
= inquiry_argument
;
6070 actual_arg_save
= actual_arg
;
6071 first_actual_arg_save
= first_actual_arg
;
6073 if (e
->expr_type
!= EXPR_VARIABLE
)
6075 inquiry_argument
= false;
6077 first_actual_arg
= false;
6080 switch (e
->expr_type
)
6083 t
= resolve_operator (e
);
6089 if (check_host_association (e
))
6090 t
= resolve_function (e
);
6093 t
= resolve_variable (e
);
6095 expression_rank (e
);
6098 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6099 && e
->ref
->type
!= REF_SUBSTRING
)
6100 gfc_resolve_substring_charlen (e
);
6105 t
= resolve_typebound_function (e
);
6108 case EXPR_SUBSTRING
:
6109 t
= resolve_ref (e
);
6118 t
= resolve_expr_ppc (e
);
6123 if (!resolve_ref (e
))
6126 t
= gfc_resolve_array_constructor (e
);
6127 /* Also try to expand a constructor. */
6130 expression_rank (e
);
6131 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6132 gfc_expand_constructor (e
, false);
6135 /* This provides the opportunity for the length of constructors with
6136 character valued function elements to propagate the string length
6137 to the expression. */
6138 if (t
&& e
->ts
.type
== BT_CHARACTER
)
6140 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6141 here rather then add a duplicate test for it above. */
6142 gfc_expand_constructor (e
, false);
6143 t
= gfc_resolve_character_array_constructor (e
);
6148 case EXPR_STRUCTURE
:
6149 t
= resolve_ref (e
);
6153 t
= resolve_structure_cons (e
, 0);
6157 t
= gfc_simplify_expr (e
, 0);
6161 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6164 if (e
->ts
.type
== BT_CHARACTER
&& t
&& !e
->ts
.u
.cl
)
6167 inquiry_argument
= inquiry_save
;
6168 actual_arg
= actual_arg_save
;
6169 first_actual_arg
= first_actual_arg_save
;
6175 /* Resolve an expression from an iterator. They must be scalar and have
6176 INTEGER or (optionally) REAL type. */
6179 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6180 const char *name_msgid
)
6182 if (!gfc_resolve_expr (expr
))
6185 if (expr
->rank
!= 0)
6187 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6191 if (expr
->ts
.type
!= BT_INTEGER
)
6193 if (expr
->ts
.type
== BT_REAL
)
6196 return gfc_notify_std (GFC_STD_F95_DEL
,
6197 "%s at %L must be integer",
6198 _(name_msgid
), &expr
->where
);
6201 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6208 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6216 /* Resolve the expressions in an iterator structure. If REAL_OK is
6217 false allow only INTEGER type iterators, otherwise allow REAL types.
6218 Set own_scope to true for ac-implied-do and data-implied-do as those
6219 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6222 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6224 if (!gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable"))
6227 if (!gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6228 _("iterator variable")))
6231 if (!gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6232 "Start expression in DO loop"))
6235 if (!gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6236 "End expression in DO loop"))
6239 if (!gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6240 "Step expression in DO loop"))
6243 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6245 if ((iter
->step
->ts
.type
== BT_INTEGER
6246 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6247 || (iter
->step
->ts
.type
== BT_REAL
6248 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6250 gfc_error ("Step expression in DO loop at %L cannot be zero",
6251 &iter
->step
->where
);
6256 /* Convert start, end, and step to the same type as var. */
6257 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6258 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6259 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6261 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6262 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6263 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6265 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6266 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6267 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6269 if (iter
->start
->expr_type
== EXPR_CONSTANT
6270 && iter
->end
->expr_type
== EXPR_CONSTANT
6271 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6274 if (iter
->start
->ts
.type
== BT_INTEGER
)
6276 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6277 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6281 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6282 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6284 if (gfc_option
.warn_zerotrip
&&
6285 ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0)))
6286 gfc_warning ("DO loop at %L will be executed zero times"
6287 " (use -Wno-zerotrip to suppress)",
6288 &iter
->step
->where
);
6295 /* Traversal function for find_forall_index. f == 2 signals that
6296 that variable itself is not to be checked - only the references. */
6299 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6301 if (expr
->expr_type
!= EXPR_VARIABLE
)
6304 /* A scalar assignment */
6305 if (!expr
->ref
|| *f
== 1)
6307 if (expr
->symtree
->n
.sym
== sym
)
6319 /* Check whether the FORALL index appears in the expression or not.
6320 Returns true if SYM is found in EXPR. */
6323 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6325 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6332 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6333 to be a scalar INTEGER variable. The subscripts and stride are scalar
6334 INTEGERs, and if stride is a constant it must be nonzero.
6335 Furthermore "A subscript or stride in a forall-triplet-spec shall
6336 not contain a reference to any index-name in the
6337 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6340 resolve_forall_iterators (gfc_forall_iterator
*it
)
6342 gfc_forall_iterator
*iter
, *iter2
;
6344 for (iter
= it
; iter
; iter
= iter
->next
)
6346 if (gfc_resolve_expr (iter
->var
)
6347 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6348 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6351 if (gfc_resolve_expr (iter
->start
)
6352 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6353 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6354 &iter
->start
->where
);
6355 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6356 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6358 if (gfc_resolve_expr (iter
->end
)
6359 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6360 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6362 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6363 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6365 if (gfc_resolve_expr (iter
->stride
))
6367 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6368 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6369 &iter
->stride
->where
, "INTEGER");
6371 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6372 && mpz_cmp_ui (iter
->stride
->value
.integer
, 0) == 0)
6373 gfc_error ("FORALL stride expression at %L cannot be zero",
6374 &iter
->stride
->where
);
6376 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6377 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6380 for (iter
= it
; iter
; iter
= iter
->next
)
6381 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6383 if (find_forall_index (iter2
->start
, iter
->var
->symtree
->n
.sym
, 0)
6384 || find_forall_index (iter2
->end
, iter
->var
->symtree
->n
.sym
, 0)
6385 || find_forall_index (iter2
->stride
, iter
->var
->symtree
->n
.sym
, 0))
6386 gfc_error ("FORALL index '%s' may not appear in triplet "
6387 "specification at %L", iter
->var
->symtree
->name
,
6388 &iter2
->start
->where
);
6393 /* Given a pointer to a symbol that is a derived type, see if it's
6394 inaccessible, i.e. if it's defined in another module and the components are
6395 PRIVATE. The search is recursive if necessary. Returns zero if no
6396 inaccessible components are found, nonzero otherwise. */
6399 derived_inaccessible (gfc_symbol
*sym
)
6403 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6406 for (c
= sym
->components
; c
; c
= c
->next
)
6408 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6416 /* Resolve the argument of a deallocate expression. The expression must be
6417 a pointer or a full array. */
6420 resolve_deallocate_expr (gfc_expr
*e
)
6422 symbol_attribute attr
;
6423 int allocatable
, pointer
;
6429 if (!gfc_resolve_expr (e
))
6432 if (e
->expr_type
!= EXPR_VARIABLE
)
6435 sym
= e
->symtree
->n
.sym
;
6436 unlimited
= UNLIMITED_POLY(sym
);
6438 if (sym
->ts
.type
== BT_CLASS
)
6440 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6441 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6445 allocatable
= sym
->attr
.allocatable
;
6446 pointer
= sym
->attr
.pointer
;
6448 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6453 if (ref
->u
.ar
.type
!= AR_FULL
6454 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6455 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6460 c
= ref
->u
.c
.component
;
6461 if (c
->ts
.type
== BT_CLASS
)
6463 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6464 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6468 allocatable
= c
->attr
.allocatable
;
6469 pointer
= c
->attr
.pointer
;
6479 attr
= gfc_expr_attr (e
);
6481 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6484 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6490 if (gfc_is_coindexed (e
))
6492 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6497 && !gfc_check_vardef_context (e
, true, true, false,
6498 _("DEALLOCATE object")))
6500 if (!gfc_check_vardef_context (e
, false, true, false,
6501 _("DEALLOCATE object")))
6508 /* Returns true if the expression e contains a reference to the symbol sym. */
6510 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6512 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6519 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6521 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6525 /* Given the expression node e for an allocatable/pointer of derived type to be
6526 allocated, get the expression node to be initialized afterwards (needed for
6527 derived types with default initializers, and derived types with allocatable
6528 components that need nullification.) */
6531 gfc_expr_to_initialize (gfc_expr
*e
)
6537 result
= gfc_copy_expr (e
);
6539 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6540 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6541 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6543 ref
->u
.ar
.type
= AR_FULL
;
6545 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6546 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6551 gfc_free_shape (&result
->shape
, result
->rank
);
6553 /* Recalculate rank, shape, etc. */
6554 gfc_resolve_expr (result
);
6559 /* If the last ref of an expression is an array ref, return a copy of the
6560 expression with that one removed. Otherwise, a copy of the original
6561 expression. This is used for allocate-expressions and pointer assignment
6562 LHS, where there may be an array specification that needs to be stripped
6563 off when using gfc_check_vardef_context. */
6566 remove_last_array_ref (gfc_expr
* e
)
6571 e2
= gfc_copy_expr (e
);
6572 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6573 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6575 gfc_free_ref_list (*r
);
6584 /* Used in resolve_allocate_expr to check that a allocation-object and
6585 a source-expr are conformable. This does not catch all possible
6586 cases; in particular a runtime checking is needed. */
6589 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6592 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6594 /* First compare rank. */
6595 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6597 gfc_error ("Source-expr at %L must be scalar or have the "
6598 "same rank as the allocate-object at %L",
6599 &e1
->where
, &e2
->where
);
6610 for (i
= 0; i
< e1
->rank
; i
++)
6612 if (tail
->u
.ar
.start
[i
] == NULL
)
6615 if (tail
->u
.ar
.end
[i
])
6617 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6618 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6619 mpz_add_ui (s
, s
, 1);
6623 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6626 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6628 gfc_error ("Source-expr at %L and allocate-object at %L must "
6629 "have the same shape", &e1
->where
, &e2
->where
);
6642 /* Resolve the expression in an ALLOCATE statement, doing the additional
6643 checks to see whether the expression is OK or not. The expression must
6644 have a trailing array reference that gives the size of the array. */
6647 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6649 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6653 symbol_attribute attr
;
6654 gfc_ref
*ref
, *ref2
;
6657 gfc_symbol
*sym
= NULL
;
6662 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6663 checking of coarrays. */
6664 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6665 if (ref
->next
== NULL
)
6668 if (ref
&& ref
->type
== REF_ARRAY
)
6669 ref
->u
.ar
.in_allocate
= true;
6671 if (!gfc_resolve_expr (e
))
6674 /* Make sure the expression is allocatable or a pointer. If it is
6675 pointer, the next-to-last reference must be a pointer. */
6679 sym
= e
->symtree
->n
.sym
;
6681 /* Check whether ultimate component is abstract and CLASS. */
6684 /* Is the allocate-object unlimited polymorphic? */
6685 unlimited
= UNLIMITED_POLY(e
);
6687 if (e
->expr_type
!= EXPR_VARIABLE
)
6690 attr
= gfc_expr_attr (e
);
6691 pointer
= attr
.pointer
;
6692 dimension
= attr
.dimension
;
6693 codimension
= attr
.codimension
;
6697 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
6699 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6700 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6701 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6702 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6703 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6707 allocatable
= sym
->attr
.allocatable
;
6708 pointer
= sym
->attr
.pointer
;
6709 dimension
= sym
->attr
.dimension
;
6710 codimension
= sym
->attr
.codimension
;
6715 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6720 if (ref
->u
.ar
.codimen
> 0)
6723 for (n
= ref
->u
.ar
.dimen
;
6724 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
6725 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
6732 if (ref
->next
!= NULL
)
6740 gfc_error ("Coindexed allocatable object at %L",
6745 c
= ref
->u
.c
.component
;
6746 if (c
->ts
.type
== BT_CLASS
)
6748 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6749 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6750 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6751 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6752 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6756 allocatable
= c
->attr
.allocatable
;
6757 pointer
= c
->attr
.pointer
;
6758 dimension
= c
->attr
.dimension
;
6759 codimension
= c
->attr
.codimension
;
6760 is_abstract
= c
->attr
.abstract
;
6772 /* Check for F08:C628. */
6773 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
6775 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6780 /* Some checks for the SOURCE tag. */
6783 /* Check F03:C631. */
6784 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6786 gfc_error ("Type of entity at %L is type incompatible with "
6787 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6791 /* Check F03:C632 and restriction following Note 6.18. */
6792 if (code
->expr3
->rank
> 0 && !unlimited
6793 && !conformable_arrays (code
->expr3
, e
))
6796 /* Check F03:C633. */
6797 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
6799 gfc_error ("The allocate-object at %L and the source-expr at %L "
6800 "shall have the same kind type parameter",
6801 &e
->where
, &code
->expr3
->where
);
6805 /* Check F2008, C642. */
6806 if (code
->expr3
->ts
.type
== BT_DERIVED
6807 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
6808 || (code
->expr3
->ts
.u
.derived
->from_intmod
6809 == INTMOD_ISO_FORTRAN_ENV
6810 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
6811 == ISOFORTRAN_LOCK_TYPE
)))
6813 gfc_error ("The source-expr at %L shall neither be of type "
6814 "LOCK_TYPE nor have a LOCK_TYPE component if "
6815 "allocate-object at %L is a coarray",
6816 &code
->expr3
->where
, &e
->where
);
6821 /* Check F08:C629. */
6822 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6825 gcc_assert (e
->ts
.type
== BT_CLASS
);
6826 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6827 "type-spec or source-expr", sym
->name
, &e
->where
);
6831 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
6833 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
6834 code
->ext
.alloc
.ts
.u
.cl
->length
);
6835 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
6837 gfc_error ("Allocating %s at %L with type-spec requires the same "
6838 "character-length parameter as in the declaration",
6839 sym
->name
, &e
->where
);
6844 /* In the variable definition context checks, gfc_expr_attr is used
6845 on the expression. This is fooled by the array specification
6846 present in e, thus we have to eliminate that one temporarily. */
6847 e2
= remove_last_array_ref (e
);
6850 t
= gfc_check_vardef_context (e2
, true, true, false,
6851 _("ALLOCATE object"));
6853 t
= gfc_check_vardef_context (e2
, false, true, false,
6854 _("ALLOCATE object"));
6859 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
6860 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6862 /* For class arrays, the initialization with SOURCE is done
6863 using _copy and trans_call. It is convenient to exploit that
6864 when the allocated type is different from the declared type but
6865 no SOURCE exists by setting expr3. */
6866 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
6868 else if (!code
->expr3
)
6870 /* Set up default initializer if needed. */
6874 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6875 ts
= code
->ext
.alloc
.ts
;
6879 if (ts
.type
== BT_CLASS
)
6880 ts
= ts
.u
.derived
->components
->ts
;
6882 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6884 gfc_code
*init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
6885 init_st
->loc
= code
->loc
;
6886 init_st
->expr1
= gfc_expr_to_initialize (e
);
6887 init_st
->expr2
= init_e
;
6888 init_st
->next
= code
->next
;
6889 code
->next
= init_st
;
6892 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6894 /* Default initialization via MOLD (non-polymorphic). */
6895 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6896 gfc_resolve_expr (rhs
);
6897 gfc_free_expr (code
->expr3
);
6901 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6903 /* Make sure the vtab symbol is present when
6904 the module variables are generated. */
6905 gfc_typespec ts
= e
->ts
;
6907 ts
= code
->expr3
->ts
;
6908 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6909 ts
= code
->ext
.alloc
.ts
;
6911 gfc_find_derived_vtab (ts
.u
.derived
);
6914 e
= gfc_expr_to_initialize (e
);
6916 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
6918 /* Again, make sure the vtab symbol is present when
6919 the module variables are generated. */
6920 gfc_typespec
*ts
= NULL
;
6922 ts
= &code
->expr3
->ts
;
6924 ts
= &code
->ext
.alloc
.ts
;
6928 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
6929 gfc_find_derived_vtab (ts
->u
.derived
);
6931 gfc_find_intrinsic_vtab (ts
);
6934 e
= gfc_expr_to_initialize (e
);
6937 if (dimension
== 0 && codimension
== 0)
6940 /* Make sure the last reference node is an array specification. */
6942 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6943 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6945 gfc_error ("Array specification required in ALLOCATE statement "
6946 "at %L", &e
->where
);
6950 /* Make sure that the array section reference makes sense in the
6951 context of an ALLOCATE specification. */
6956 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
6957 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
6959 gfc_error ("Coarray specification required in ALLOCATE statement "
6960 "at %L", &e
->where
);
6964 for (i
= 0; i
< ar
->dimen
; i
++)
6966 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6969 switch (ar
->dimen_type
[i
])
6975 if (ar
->start
[i
] != NULL
6976 && ar
->end
[i
] != NULL
6977 && ar
->stride
[i
] == NULL
)
6980 /* Fall Through... */
6985 case DIMEN_THIS_IMAGE
:
6986 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6992 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6994 sym
= a
->expr
->symtree
->n
.sym
;
6996 /* TODO - check derived type components. */
6997 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7000 if ((ar
->start
[i
] != NULL
7001 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7002 || (ar
->end
[i
] != NULL
7003 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7005 gfc_error ("'%s' must not appear in the array specification at "
7006 "%L in the same ALLOCATE statement where it is "
7007 "itself allocated", sym
->name
, &ar
->where
);
7013 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7015 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7016 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7018 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7020 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7021 "statement at %L", &e
->where
);
7027 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7028 && ar
->stride
[i
] == NULL
)
7031 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7044 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7046 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7047 gfc_alloc
*a
, *p
, *q
;
7050 errmsg
= code
->expr2
;
7052 /* Check the stat variable. */
7055 gfc_check_vardef_context (stat
, false, false, false,
7056 _("STAT variable"));
7058 if ((stat
->ts
.type
!= BT_INTEGER
7059 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7060 || stat
->ref
->type
== REF_COMPONENT
)))
7062 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7063 "variable", &stat
->where
);
7065 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7066 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7068 gfc_ref
*ref1
, *ref2
;
7071 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7072 ref1
= ref1
->next
, ref2
= ref2
->next
)
7074 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7076 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7085 gfc_error ("Stat-variable at %L shall not be %sd within "
7086 "the same %s statement", &stat
->where
, fcn
, fcn
);
7092 /* Check the errmsg variable. */
7096 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7099 gfc_check_vardef_context (errmsg
, false, false, false,
7100 _("ERRMSG variable"));
7102 if ((errmsg
->ts
.type
!= BT_CHARACTER
7104 && (errmsg
->ref
->type
== REF_ARRAY
7105 || errmsg
->ref
->type
== REF_COMPONENT
)))
7106 || errmsg
->rank
> 0 )
7107 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7108 "variable", &errmsg
->where
);
7110 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7111 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7113 gfc_ref
*ref1
, *ref2
;
7116 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7117 ref1
= ref1
->next
, ref2
= ref2
->next
)
7119 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7121 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7130 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7131 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7137 /* Check that an allocate-object appears only once in the statement. */
7139 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7142 for (q
= p
->next
; q
; q
= q
->next
)
7145 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7147 /* This is a potential collision. */
7148 gfc_ref
*pr
= pe
->ref
;
7149 gfc_ref
*qr
= qe
->ref
;
7151 /* Follow the references until
7152 a) They start to differ, in which case there is no error;
7153 you can deallocate a%b and a%c in a single statement
7154 b) Both of them stop, which is an error
7155 c) One of them stops, which is also an error. */
7158 if (pr
== NULL
&& qr
== NULL
)
7160 gfc_error ("Allocate-object at %L also appears at %L",
7161 &pe
->where
, &qe
->where
);
7164 else if (pr
!= NULL
&& qr
== NULL
)
7166 gfc_error ("Allocate-object at %L is subobject of"
7167 " object at %L", &pe
->where
, &qe
->where
);
7170 else if (pr
== NULL
&& qr
!= NULL
)
7172 gfc_error ("Allocate-object at %L is subobject of"
7173 " object at %L", &qe
->where
, &pe
->where
);
7176 /* Here, pr != NULL && qr != NULL */
7177 gcc_assert(pr
->type
== qr
->type
);
7178 if (pr
->type
== REF_ARRAY
)
7180 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7182 gcc_assert (qr
->type
== REF_ARRAY
);
7184 if (pr
->next
&& qr
->next
)
7187 gfc_array_ref
*par
= &(pr
->u
.ar
);
7188 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7190 for (i
=0; i
<par
->dimen
; i
++)
7192 if ((par
->start
[i
] != NULL
7193 || qar
->start
[i
] != NULL
)
7194 && gfc_dep_compare_expr (par
->start
[i
],
7195 qar
->start
[i
]) != 0)
7202 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7215 if (strcmp (fcn
, "ALLOCATE") == 0)
7217 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7218 resolve_allocate_expr (a
->expr
, code
);
7222 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7223 resolve_deallocate_expr (a
->expr
);
7228 /************ SELECT CASE resolution subroutines ************/
7230 /* Callback function for our mergesort variant. Determines interval
7231 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7232 op1 > op2. Assumes we're not dealing with the default case.
7233 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7234 There are nine situations to check. */
7237 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7241 if (op1
->low
== NULL
) /* op1 = (:L) */
7243 /* op2 = (:N), so overlap. */
7245 /* op2 = (M:) or (M:N), L < M */
7246 if (op2
->low
!= NULL
7247 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7250 else if (op1
->high
== NULL
) /* op1 = (K:) */
7252 /* op2 = (M:), so overlap. */
7254 /* op2 = (:N) or (M:N), K > N */
7255 if (op2
->high
!= NULL
7256 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7259 else /* op1 = (K:L) */
7261 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7262 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7264 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7265 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7267 else /* op2 = (M:N) */
7271 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7274 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7283 /* Merge-sort a double linked case list, detecting overlap in the
7284 process. LIST is the head of the double linked case list before it
7285 is sorted. Returns the head of the sorted list if we don't see any
7286 overlap, or NULL otherwise. */
7289 check_case_overlap (gfc_case
*list
)
7291 gfc_case
*p
, *q
, *e
, *tail
;
7292 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7294 /* If the passed list was empty, return immediately. */
7301 /* Loop unconditionally. The only exit from this loop is a return
7302 statement, when we've finished sorting the case list. */
7309 /* Count the number of merges we do in this pass. */
7312 /* Loop while there exists a merge to be done. */
7317 /* Count this merge. */
7320 /* Cut the list in two pieces by stepping INSIZE places
7321 forward in the list, starting from P. */
7324 for (i
= 0; i
< insize
; i
++)
7333 /* Now we have two lists. Merge them! */
7334 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7336 /* See from which the next case to merge comes from. */
7339 /* P is empty so the next case must come from Q. */
7344 else if (qsize
== 0 || q
== NULL
)
7353 cmp
= compare_cases (p
, q
);
7356 /* The whole case range for P is less than the
7364 /* The whole case range for Q is greater than
7365 the case range for P. */
7372 /* The cases overlap, or they are the same
7373 element in the list. Either way, we must
7374 issue an error and get the next case from P. */
7375 /* FIXME: Sort P and Q by line number. */
7376 gfc_error ("CASE label at %L overlaps with CASE "
7377 "label at %L", &p
->where
, &q
->where
);
7385 /* Add the next element to the merged list. */
7394 /* P has now stepped INSIZE places along, and so has Q. So
7395 they're the same. */
7400 /* If we have done only one merge or none at all, we've
7401 finished sorting the cases. */
7410 /* Otherwise repeat, merging lists twice the size. */
7416 /* Check to see if an expression is suitable for use in a CASE statement.
7417 Makes sure that all case expressions are scalar constants of the same
7418 type. Return false if anything is wrong. */
7421 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7423 if (e
== NULL
) return true;
7425 if (e
->ts
.type
!= case_expr
->ts
.type
)
7427 gfc_error ("Expression in CASE statement at %L must be of type %s",
7428 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7432 /* C805 (R808) For a given case-construct, each case-value shall be of
7433 the same type as case-expr. For character type, length differences
7434 are allowed, but the kind type parameters shall be the same. */
7436 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7438 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7439 &e
->where
, case_expr
->ts
.kind
);
7443 /* Convert the case value kind to that of case expression kind,
7446 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7447 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7451 gfc_error ("Expression in CASE statement at %L must be scalar",
7460 /* Given a completely parsed select statement, we:
7462 - Validate all expressions and code within the SELECT.
7463 - Make sure that the selection expression is not of the wrong type.
7464 - Make sure that no case ranges overlap.
7465 - Eliminate unreachable cases and unreachable code resulting from
7466 removing case labels.
7468 The standard does allow unreachable cases, e.g. CASE (5:3). But
7469 they are a hassle for code generation, and to prevent that, we just
7470 cut them out here. This is not necessary for overlapping cases
7471 because they are illegal and we never even try to generate code.
7473 We have the additional caveat that a SELECT construct could have
7474 been a computed GOTO in the source code. Fortunately we can fairly
7475 easily work around that here: The case_expr for a "real" SELECT CASE
7476 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7477 we have to do is make sure that the case_expr is a scalar integer
7481 resolve_select (gfc_code
*code
, bool select_type
)
7484 gfc_expr
*case_expr
;
7485 gfc_case
*cp
, *default_case
, *tail
, *head
;
7486 int seen_unreachable
;
7492 if (code
->expr1
== NULL
)
7494 /* This was actually a computed GOTO statement. */
7495 case_expr
= code
->expr2
;
7496 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7497 gfc_error ("Selection expression in computed GOTO statement "
7498 "at %L must be a scalar integer expression",
7501 /* Further checking is not necessary because this SELECT was built
7502 by the compiler, so it should always be OK. Just move the
7503 case_expr from expr2 to expr so that we can handle computed
7504 GOTOs as normal SELECTs from here on. */
7505 code
->expr1
= code
->expr2
;
7510 case_expr
= code
->expr1
;
7511 type
= case_expr
->ts
.type
;
7514 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7516 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7517 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7519 /* Punt. Going on here just produce more garbage error messages. */
7524 if (!select_type
&& case_expr
->rank
!= 0)
7526 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7527 "expression", &case_expr
->where
);
7533 /* Raise a warning if an INTEGER case value exceeds the range of
7534 the case-expr. Later, all expressions will be promoted to the
7535 largest kind of all case-labels. */
7537 if (type
== BT_INTEGER
)
7538 for (body
= code
->block
; body
; body
= body
->block
)
7539 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7542 && gfc_check_integer_range (cp
->low
->value
.integer
,
7543 case_expr
->ts
.kind
) != ARITH_OK
)
7544 gfc_warning ("Expression in CASE statement at %L is "
7545 "not in the range of %s", &cp
->low
->where
,
7546 gfc_typename (&case_expr
->ts
));
7549 && cp
->low
!= cp
->high
7550 && gfc_check_integer_range (cp
->high
->value
.integer
,
7551 case_expr
->ts
.kind
) != ARITH_OK
)
7552 gfc_warning ("Expression in CASE statement at %L is "
7553 "not in the range of %s", &cp
->high
->where
,
7554 gfc_typename (&case_expr
->ts
));
7557 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7558 of the SELECT CASE expression and its CASE values. Walk the lists
7559 of case values, and if we find a mismatch, promote case_expr to
7560 the appropriate kind. */
7562 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7564 for (body
= code
->block
; body
; body
= body
->block
)
7566 /* Walk the case label list. */
7567 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7569 /* Intercept the DEFAULT case. It does not have a kind. */
7570 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7573 /* Unreachable case ranges are discarded, so ignore. */
7574 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7575 && cp
->low
!= cp
->high
7576 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7580 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7581 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7583 if (cp
->high
!= NULL
7584 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7585 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7590 /* Assume there is no DEFAULT case. */
7591 default_case
= NULL
;
7596 for (body
= code
->block
; body
; body
= body
->block
)
7598 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7600 seen_unreachable
= 0;
7602 /* Walk the case label list, making sure that all case labels
7604 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7606 /* Count the number of cases in the whole construct. */
7609 /* Intercept the DEFAULT case. */
7610 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7612 if (default_case
!= NULL
)
7614 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7615 "by a second DEFAULT CASE at %L",
7616 &default_case
->where
, &cp
->where
);
7627 /* Deal with single value cases and case ranges. Errors are
7628 issued from the validation function. */
7629 if (!validate_case_label_expr (cp
->low
, case_expr
)
7630 || !validate_case_label_expr (cp
->high
, case_expr
))
7636 if (type
== BT_LOGICAL
7637 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7638 || cp
->low
!= cp
->high
))
7640 gfc_error ("Logical range in CASE statement at %L is not "
7641 "allowed", &cp
->low
->where
);
7646 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7649 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7650 if (value
& seen_logical
)
7652 gfc_error ("Constant logical value in CASE statement "
7653 "is repeated at %L",
7658 seen_logical
|= value
;
7661 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7662 && cp
->low
!= cp
->high
7663 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7665 if (gfc_option
.warn_surprising
)
7666 gfc_warning ("Range specification at %L can never "
7667 "be matched", &cp
->where
);
7669 cp
->unreachable
= 1;
7670 seen_unreachable
= 1;
7674 /* If the case range can be matched, it can also overlap with
7675 other cases. To make sure it does not, we put it in a
7676 double linked list here. We sort that with a merge sort
7677 later on to detect any overlapping cases. */
7681 head
->right
= head
->left
= NULL
;
7686 tail
->right
->left
= tail
;
7693 /* It there was a failure in the previous case label, give up
7694 for this case label list. Continue with the next block. */
7698 /* See if any case labels that are unreachable have been seen.
7699 If so, we eliminate them. This is a bit of a kludge because
7700 the case lists for a single case statement (label) is a
7701 single forward linked lists. */
7702 if (seen_unreachable
)
7704 /* Advance until the first case in the list is reachable. */
7705 while (body
->ext
.block
.case_list
!= NULL
7706 && body
->ext
.block
.case_list
->unreachable
)
7708 gfc_case
*n
= body
->ext
.block
.case_list
;
7709 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7711 gfc_free_case_list (n
);
7714 /* Strip all other unreachable cases. */
7715 if (body
->ext
.block
.case_list
)
7717 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7719 if (cp
->next
->unreachable
)
7721 gfc_case
*n
= cp
->next
;
7722 cp
->next
= cp
->next
->next
;
7724 gfc_free_case_list (n
);
7731 /* See if there were overlapping cases. If the check returns NULL,
7732 there was overlap. In that case we don't do anything. If head
7733 is non-NULL, we prepend the DEFAULT case. The sorted list can
7734 then used during code generation for SELECT CASE constructs with
7735 a case expression of a CHARACTER type. */
7738 head
= check_case_overlap (head
);
7740 /* Prepend the default_case if it is there. */
7741 if (head
!= NULL
&& default_case
)
7743 default_case
->left
= NULL
;
7744 default_case
->right
= head
;
7745 head
->left
= default_case
;
7749 /* Eliminate dead blocks that may be the result if we've seen
7750 unreachable case labels for a block. */
7751 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7753 if (body
->block
->ext
.block
.case_list
== NULL
)
7755 /* Cut the unreachable block from the code chain. */
7756 gfc_code
*c
= body
->block
;
7757 body
->block
= c
->block
;
7759 /* Kill the dead block, but not the blocks below it. */
7761 gfc_free_statements (c
);
7765 /* More than two cases is legal but insane for logical selects.
7766 Issue a warning for it. */
7767 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7769 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7774 /* Check if a derived type is extensible. */
7777 gfc_type_is_extensible (gfc_symbol
*sym
)
7779 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
7780 || (sym
->attr
.is_class
7781 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
7785 /* Resolve an associate-name: Resolve target and ensure the type-spec is
7786 correct as well as possibly the array-spec. */
7789 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7793 gcc_assert (sym
->assoc
);
7794 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7796 /* If this is for SELECT TYPE, the target may not yet be set. In that
7797 case, return. Resolution will be called later manually again when
7799 target
= sym
->assoc
->target
;
7802 gcc_assert (!sym
->assoc
->dangling
);
7804 if (resolve_target
&& !gfc_resolve_expr (target
))
7807 /* For variable targets, we get some attributes from the target. */
7808 if (target
->expr_type
== EXPR_VARIABLE
)
7812 gcc_assert (target
->symtree
);
7813 tsym
= target
->symtree
->n
.sym
;
7815 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7816 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7818 sym
->attr
.target
= tsym
->attr
.target
7819 || gfc_expr_attr (target
).pointer
;
7822 /* Get type if this was not already set. Note that it can be
7823 some other type than the target in case this is a SELECT TYPE
7824 selector! So we must not update when the type is already there. */
7825 if (sym
->ts
.type
== BT_UNKNOWN
)
7826 sym
->ts
= target
->ts
;
7827 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7829 /* See if this is a valid association-to-variable. */
7830 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7831 && !gfc_has_vector_subscript (target
));
7833 /* Finally resolve if this is an array or not. */
7834 if (sym
->attr
.dimension
&& target
->rank
== 0)
7836 gfc_error ("Associate-name '%s' at %L is used as array",
7837 sym
->name
, &sym
->declared_at
);
7838 sym
->attr
.dimension
= 0;
7842 /* We cannot deal with class selectors that need temporaries. */
7843 if (target
->ts
.type
== BT_CLASS
7844 && gfc_ref_needs_temporary_p (target
->ref
))
7846 gfc_error ("CLASS selector at %L needs a temporary which is not "
7847 "yet implemented", &target
->where
);
7851 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
7852 sym
->attr
.dimension
= 1;
7853 else if (target
->ts
.type
== BT_CLASS
)
7854 gfc_fix_class_refs (target
);
7856 /* The associate-name will have a correct type by now. Make absolutely
7857 sure that it has not picked up a dimension attribute. */
7858 if (sym
->ts
.type
== BT_CLASS
)
7859 sym
->attr
.dimension
= 0;
7861 if (sym
->attr
.dimension
)
7863 sym
->as
= gfc_get_array_spec ();
7864 sym
->as
->rank
= target
->rank
;
7865 sym
->as
->type
= AS_DEFERRED
;
7867 /* Target must not be coindexed, thus the associate-variable
7869 sym
->as
->corank
= 0;
7872 /* Mark this as an associate variable. */
7873 sym
->attr
.associate_var
= 1;
7875 /* If the target is a good class object, so is the associate variable. */
7876 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
7877 sym
->attr
.class_ok
= 1;
7881 /* Resolve a SELECT TYPE statement. */
7884 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7886 gfc_symbol
*selector_type
;
7887 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7888 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7891 char name
[GFC_MAX_SYMBOL_LEN
];
7896 ns
= code
->ext
.block
.ns
;
7899 /* Check for F03:C813. */
7900 if (code
->expr1
->ts
.type
!= BT_CLASS
7901 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7903 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7904 "at %L", &code
->loc
);
7908 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
7913 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7914 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7915 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7917 /* F2008: C803 The selector expression must not be coindexed. */
7918 if (gfc_is_coindexed (code
->expr2
))
7920 gfc_error ("Selector at %L must not be coindexed",
7921 &code
->expr2
->where
);
7928 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7930 if (gfc_is_coindexed (code
->expr1
))
7932 gfc_error ("Selector at %L must not be coindexed",
7933 &code
->expr1
->where
);
7938 /* Loop over TYPE IS / CLASS IS cases. */
7939 for (body
= code
->block
; body
; body
= body
->block
)
7941 c
= body
->ext
.block
.case_list
;
7943 /* Check F03:C815. */
7944 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7945 && !selector_type
->attr
.unlimited_polymorphic
7946 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7948 gfc_error ("Derived type '%s' at %L must be extensible",
7949 c
->ts
.u
.derived
->name
, &c
->where
);
7954 /* Check F03:C816. */
7955 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
7956 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
7957 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
7959 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7960 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7961 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7963 gfc_error ("Unexpected intrinsic type '%s' at %L",
7964 gfc_basic_typename (c
->ts
.type
), &c
->where
);
7969 /* Check F03:C814. */
7970 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
7972 gfc_error ("The type-spec at %L shall specify that each length "
7973 "type parameter is assumed", &c
->where
);
7978 /* Intercept the DEFAULT case. */
7979 if (c
->ts
.type
== BT_UNKNOWN
)
7981 /* Check F03:C818. */
7984 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7985 "by a second DEFAULT CASE at %L",
7986 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7991 default_case
= body
;
7998 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7999 target if present. If there are any EXIT statements referring to the
8000 SELECT TYPE construct, this is no problem because the gfc_code
8001 reference stays the same and EXIT is equally possible from the BLOCK
8002 it is changed to. */
8003 code
->op
= EXEC_BLOCK
;
8006 gfc_association_list
* assoc
;
8008 assoc
= gfc_get_association_list ();
8009 assoc
->st
= code
->expr1
->symtree
;
8010 assoc
->target
= gfc_copy_expr (code
->expr2
);
8011 assoc
->target
->where
= code
->expr2
->where
;
8012 /* assoc->variable will be set by resolve_assoc_var. */
8014 code
->ext
.block
.assoc
= assoc
;
8015 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8017 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8020 code
->ext
.block
.assoc
= NULL
;
8022 /* Add EXEC_SELECT to switch on type. */
8023 new_st
= gfc_get_code (code
->op
);
8024 new_st
->expr1
= code
->expr1
;
8025 new_st
->expr2
= code
->expr2
;
8026 new_st
->block
= code
->block
;
8027 code
->expr1
= code
->expr2
= NULL
;
8032 ns
->code
->next
= new_st
;
8034 code
->op
= EXEC_SELECT
;
8036 gfc_add_vptr_component (code
->expr1
);
8037 gfc_add_hash_component (code
->expr1
);
8039 /* Loop over TYPE IS / CLASS IS cases. */
8040 for (body
= code
->block
; body
; body
= body
->block
)
8042 c
= body
->ext
.block
.case_list
;
8044 if (c
->ts
.type
== BT_DERIVED
)
8045 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8046 c
->ts
.u
.derived
->hash_value
);
8047 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8052 ivtab
= gfc_find_intrinsic_vtab (&c
->ts
);
8053 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8054 e
= CLASS_DATA (ivtab
)->initializer
;
8055 c
->low
= c
->high
= gfc_copy_expr (e
);
8058 else if (c
->ts
.type
== BT_UNKNOWN
)
8061 /* Associate temporary to selector. This should only be done
8062 when this case is actually true, so build a new ASSOCIATE
8063 that does precisely this here (instead of using the
8066 if (c
->ts
.type
== BT_CLASS
)
8067 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8068 else if (c
->ts
.type
== BT_DERIVED
)
8069 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8070 else if (c
->ts
.type
== BT_CHARACTER
)
8072 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8073 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8074 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8075 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8076 charlen
, c
->ts
.kind
);
8079 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8082 st
= gfc_find_symtree (ns
->sym_root
, name
);
8083 gcc_assert (st
->n
.sym
->assoc
);
8084 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8085 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8086 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8087 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8089 new_st
= gfc_get_code (EXEC_BLOCK
);
8090 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8091 new_st
->ext
.block
.ns
->code
= body
->next
;
8092 body
->next
= new_st
;
8094 /* Chain in the new list only if it is marked as dangling. Otherwise
8095 there is a CASE label overlap and this is already used. Just ignore,
8096 the error is diagnosed elsewhere. */
8097 if (st
->n
.sym
->assoc
->dangling
)
8099 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8100 st
->n
.sym
->assoc
->dangling
= 0;
8103 resolve_assoc_var (st
->n
.sym
, false);
8106 /* Take out CLASS IS cases for separate treatment. */
8108 while (body
&& body
->block
)
8110 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8112 /* Add to class_is list. */
8113 if (class_is
== NULL
)
8115 class_is
= body
->block
;
8120 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8121 tail
->block
= body
->block
;
8124 /* Remove from EXEC_SELECT list. */
8125 body
->block
= body
->block
->block
;
8138 /* Add a default case to hold the CLASS IS cases. */
8139 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8140 tail
->block
= gfc_get_code (EXEC_SELECT_TYPE
);
8142 tail
->ext
.block
.case_list
= gfc_get_case ();
8143 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8145 default_case
= tail
;
8148 /* More than one CLASS IS block? */
8149 if (class_is
->block
)
8153 /* Sort CLASS IS blocks by extension level. */
8157 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8160 /* F03:C817 (check for doubles). */
8161 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8162 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8164 gfc_error ("Double CLASS IS block in SELECT TYPE "
8166 &c2
->ext
.block
.case_list
->where
);
8169 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8170 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8173 (*c1
)->block
= c2
->block
;
8183 /* Generate IF chain. */
8184 if_st
= gfc_get_code (EXEC_IF
);
8186 for (body
= class_is
; body
; body
= body
->block
)
8188 new_st
->block
= gfc_get_code (EXEC_IF
);
8189 new_st
= new_st
->block
;
8190 /* Set up IF condition: Call _gfortran_is_extension_of. */
8191 new_st
->expr1
= gfc_get_expr ();
8192 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8193 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8194 new_st
->expr1
->ts
.kind
= 4;
8195 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8196 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8197 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8198 /* Set up arguments. */
8199 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8200 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8201 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8202 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8203 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8204 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8205 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8206 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8207 new_st
->next
= body
->next
;
8209 if (default_case
->next
)
8211 new_st
->block
= gfc_get_code (EXEC_IF
);
8212 new_st
= new_st
->block
;
8213 new_st
->next
= default_case
->next
;
8216 /* Replace CLASS DEFAULT code by the IF chain. */
8217 default_case
->next
= if_st
;
8220 /* Resolve the internal code. This can not be done earlier because
8221 it requires that the sym->assoc of selectors is set already. */
8222 gfc_current_ns
= ns
;
8223 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8224 gfc_current_ns
= old_ns
;
8226 resolve_select (code
, true);
8230 /* Resolve a transfer statement. This is making sure that:
8231 -- a derived type being transferred has only non-pointer components
8232 -- a derived type being transferred doesn't have private components, unless
8233 it's being transferred from the module where the type was defined
8234 -- we're not trying to transfer a whole assumed size array. */
8237 resolve_transfer (gfc_code
*code
)
8246 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8247 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8248 exp
= exp
->value
.op
.op1
;
8250 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8252 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8253 "MOLD=", &exp
->where
);
8257 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8258 && exp
->expr_type
!= EXPR_FUNCTION
))
8261 /* If we are reading, the variable will be changed. Note that
8262 code->ext.dt may be NULL if the TRANSFER is related to
8263 an INQUIRE statement -- but in this case, we are not reading, either. */
8264 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8265 && !gfc_check_vardef_context (exp
, false, false, false,
8269 sym
= exp
->symtree
->n
.sym
;
8272 /* Go to actual component transferred. */
8273 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8274 if (ref
->type
== REF_COMPONENT
)
8275 ts
= &ref
->u
.c
.component
->ts
;
8277 if (ts
->type
== BT_CLASS
)
8279 /* FIXME: Test for defined input/output. */
8280 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8281 "it is processed by a defined input/output procedure",
8286 if (ts
->type
== BT_DERIVED
)
8288 /* Check that transferred derived type doesn't contain POINTER
8290 if (ts
->u
.derived
->attr
.pointer_comp
)
8292 gfc_error ("Data transfer element at %L cannot have POINTER "
8293 "components unless it is processed by a defined "
8294 "input/output procedure", &code
->loc
);
8299 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8301 gfc_error ("Data transfer element at %L cannot have "
8302 "procedure pointer components", &code
->loc
);
8306 if (ts
->u
.derived
->attr
.alloc_comp
)
8308 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8309 "components unless it is processed by a defined "
8310 "input/output procedure", &code
->loc
);
8314 /* C_PTR and C_FUNPTR have private components which means they can not
8315 be printed. However, if -std=gnu and not -pedantic, allow
8316 the component to be printed to help debugging. */
8317 if (ts
->u
.derived
->ts
.f90_type
== BT_VOID
)
8319 if (!gfc_notify_std (GFC_STD_GNU
, "Data transfer element at %L "
8320 "cannot have PRIVATE components", &code
->loc
))
8323 else if (derived_inaccessible (ts
->u
.derived
))
8325 gfc_error ("Data transfer element at %L cannot have "
8326 "PRIVATE components",&code
->loc
);
8331 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8332 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8334 gfc_error ("Data transfer element at %L cannot be a full reference to "
8335 "an assumed-size array", &code
->loc
);
8341 /*********** Toplevel code resolution subroutines ***********/
8343 /* Find the set of labels that are reachable from this block. We also
8344 record the last statement in each block. */
8347 find_reachable_labels (gfc_code
*block
)
8354 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8356 /* Collect labels in this block. We don't keep those corresponding
8357 to END {IF|SELECT}, these are checked in resolve_branch by going
8358 up through the code_stack. */
8359 for (c
= block
; c
; c
= c
->next
)
8361 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8362 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8365 /* Merge with labels from parent block. */
8368 gcc_assert (cs_base
->prev
->reachable_labels
);
8369 bitmap_ior_into (cs_base
->reachable_labels
,
8370 cs_base
->prev
->reachable_labels
);
8376 resolve_lock_unlock (gfc_code
*code
)
8378 if (code
->expr1
->ts
.type
!= BT_DERIVED
8379 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8380 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8381 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8382 || code
->expr1
->rank
!= 0
8383 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8384 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8385 &code
->expr1
->where
);
8389 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8390 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8391 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8392 &code
->expr2
->where
);
8395 && !gfc_check_vardef_context (code
->expr2
, false, false, false,
8396 _("STAT variable")))
8401 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8402 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8403 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8404 &code
->expr3
->where
);
8407 && !gfc_check_vardef_context (code
->expr3
, false, false, false,
8408 _("ERRMSG variable")))
8411 /* Check ACQUIRED_LOCK. */
8413 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8414 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8415 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8416 "variable", &code
->expr4
->where
);
8419 && !gfc_check_vardef_context (code
->expr4
, false, false, false,
8420 _("ACQUIRED_LOCK variable")))
8426 resolve_sync (gfc_code
*code
)
8428 /* Check imageset. The * case matches expr1 == NULL. */
8431 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8432 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8433 "INTEGER expression", &code
->expr1
->where
);
8434 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8435 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8436 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8437 &code
->expr1
->where
);
8438 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8439 && gfc_simplify_expr (code
->expr1
, 0))
8441 gfc_constructor
*cons
;
8442 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8443 for (; cons
; cons
= gfc_constructor_next (cons
))
8444 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8445 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8446 gfc_error ("Imageset argument at %L must between 1 and "
8447 "num_images()", &cons
->expr
->where
);
8453 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8454 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8455 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8456 &code
->expr2
->where
);
8460 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8461 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8462 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8463 &code
->expr3
->where
);
8467 /* Given a branch to a label, see if the branch is conforming.
8468 The code node describes where the branch is located. */
8471 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8478 /* Step one: is this a valid branching target? */
8480 if (label
->defined
== ST_LABEL_UNKNOWN
)
8482 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8487 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8489 gfc_error ("Statement at %L is not a valid branch target statement "
8490 "for the branch statement at %L", &label
->where
, &code
->loc
);
8494 /* Step two: make sure this branch is not a branch to itself ;-) */
8496 if (code
->here
== label
)
8498 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8502 /* Step three: See if the label is in the same block as the
8503 branching statement. The hard work has been done by setting up
8504 the bitmap reachable_labels. */
8506 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8508 /* Check now whether there is a CRITICAL construct; if so, check
8509 whether the label is still visible outside of the CRITICAL block,
8510 which is invalid. */
8511 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8513 if (stack
->current
->op
== EXEC_CRITICAL
8514 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8515 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8516 "label at %L", &code
->loc
, &label
->where
);
8517 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8518 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8519 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8520 "for label at %L", &code
->loc
, &label
->where
);
8526 /* Step four: If we haven't found the label in the bitmap, it may
8527 still be the label of the END of the enclosing block, in which
8528 case we find it by going up the code_stack. */
8530 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8532 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8534 if (stack
->current
->op
== EXEC_CRITICAL
)
8536 /* Note: A label at END CRITICAL does not leave the CRITICAL
8537 construct as END CRITICAL is still part of it. */
8538 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8539 " at %L", &code
->loc
, &label
->where
);
8542 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8544 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8545 "label at %L", &code
->loc
, &label
->where
);
8552 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8556 /* The label is not in an enclosing block, so illegal. This was
8557 allowed in Fortran 66, so we allow it as extension. No
8558 further checks are necessary in this case. */
8559 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8560 "as the GOTO statement at %L", &label
->where
,
8566 /* Check whether EXPR1 has the same shape as EXPR2. */
8569 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8571 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8572 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8573 bool result
= false;
8576 /* Compare the rank. */
8577 if (expr1
->rank
!= expr2
->rank
)
8580 /* Compare the size of each dimension. */
8581 for (i
=0; i
<expr1
->rank
; i
++)
8583 if (!gfc_array_dimen_size (expr1
, i
, &shape
[i
]))
8586 if (!gfc_array_dimen_size (expr2
, i
, &shape2
[i
]))
8589 if (mpz_cmp (shape
[i
], shape2
[i
]))
8593 /* When either of the two expression is an assumed size array, we
8594 ignore the comparison of dimension sizes. */
8599 gfc_clear_shape (shape
, i
);
8600 gfc_clear_shape (shape2
, i
);
8605 /* Check whether a WHERE assignment target or a WHERE mask expression
8606 has the same shape as the outmost WHERE mask expression. */
8609 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8615 cblock
= code
->block
;
8617 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8618 In case of nested WHERE, only the outmost one is stored. */
8619 if (mask
== NULL
) /* outmost WHERE */
8621 else /* inner WHERE */
8628 /* Check if the mask-expr has a consistent shape with the
8629 outmost WHERE mask-expr. */
8630 if (!resolve_where_shape (cblock
->expr1
, e
))
8631 gfc_error ("WHERE mask at %L has inconsistent shape",
8632 &cblock
->expr1
->where
);
8635 /* the assignment statement of a WHERE statement, or the first
8636 statement in where-body-construct of a WHERE construct */
8637 cnext
= cblock
->next
;
8642 /* WHERE assignment statement */
8645 /* Check shape consistent for WHERE assignment target. */
8646 if (e
&& !resolve_where_shape (cnext
->expr1
, e
))
8647 gfc_error ("WHERE assignment target at %L has "
8648 "inconsistent shape", &cnext
->expr1
->where
);
8652 case EXEC_ASSIGN_CALL
:
8653 resolve_call (cnext
);
8654 if (!cnext
->resolved_sym
->attr
.elemental
)
8655 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8656 &cnext
->ext
.actual
->expr
->where
);
8659 /* WHERE or WHERE construct is part of a where-body-construct */
8661 resolve_where (cnext
, e
);
8665 gfc_error ("Unsupported statement inside WHERE at %L",
8668 /* the next statement within the same where-body-construct */
8669 cnext
= cnext
->next
;
8671 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8672 cblock
= cblock
->block
;
8677 /* Resolve assignment in FORALL construct.
8678 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8679 FORALL index variables. */
8682 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8686 for (n
= 0; n
< nvar
; n
++)
8688 gfc_symbol
*forall_index
;
8690 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8692 /* Check whether the assignment target is one of the FORALL index
8694 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8695 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8696 gfc_error ("Assignment to a FORALL index variable at %L",
8697 &code
->expr1
->where
);
8700 /* If one of the FORALL index variables doesn't appear in the
8701 assignment variable, then there could be a many-to-one
8702 assignment. Emit a warning rather than an error because the
8703 mask could be resolving this problem. */
8704 if (!find_forall_index (code
->expr1
, forall_index
, 0))
8705 gfc_warning ("The FORALL with index '%s' is not used on the "
8706 "left side of the assignment at %L and so might "
8707 "cause multiple assignment to this object",
8708 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8714 /* Resolve WHERE statement in FORALL construct. */
8717 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8718 gfc_expr
**var_expr
)
8723 cblock
= code
->block
;
8726 /* the assignment statement of a WHERE statement, or the first
8727 statement in where-body-construct of a WHERE construct */
8728 cnext
= cblock
->next
;
8733 /* WHERE assignment statement */
8735 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8738 /* WHERE operator assignment statement */
8739 case EXEC_ASSIGN_CALL
:
8740 resolve_call (cnext
);
8741 if (!cnext
->resolved_sym
->attr
.elemental
)
8742 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8743 &cnext
->ext
.actual
->expr
->where
);
8746 /* WHERE or WHERE construct is part of a where-body-construct */
8748 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8752 gfc_error ("Unsupported statement inside WHERE at %L",
8755 /* the next statement within the same where-body-construct */
8756 cnext
= cnext
->next
;
8758 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8759 cblock
= cblock
->block
;
8764 /* Traverse the FORALL body to check whether the following errors exist:
8765 1. For assignment, check if a many-to-one assignment happens.
8766 2. For WHERE statement, check the WHERE body to see if there is any
8767 many-to-one assignment. */
8770 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8774 c
= code
->block
->next
;
8780 case EXEC_POINTER_ASSIGN
:
8781 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8784 case EXEC_ASSIGN_CALL
:
8788 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8789 there is no need to handle it here. */
8793 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8798 /* The next statement in the FORALL body. */
8804 /* Counts the number of iterators needed inside a forall construct, including
8805 nested forall constructs. This is used to allocate the needed memory
8806 in gfc_resolve_forall. */
8809 gfc_count_forall_iterators (gfc_code
*code
)
8811 int max_iters
, sub_iters
, current_iters
;
8812 gfc_forall_iterator
*fa
;
8814 gcc_assert(code
->op
== EXEC_FORALL
);
8818 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8821 code
= code
->block
->next
;
8825 if (code
->op
== EXEC_FORALL
)
8827 sub_iters
= gfc_count_forall_iterators (code
);
8828 if (sub_iters
> max_iters
)
8829 max_iters
= sub_iters
;
8834 return current_iters
+ max_iters
;
8838 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8839 gfc_resolve_forall_body to resolve the FORALL body. */
8842 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8844 static gfc_expr
**var_expr
;
8845 static int total_var
= 0;
8846 static int nvar
= 0;
8848 gfc_forall_iterator
*fa
;
8853 /* Start to resolve a FORALL construct */
8854 if (forall_save
== 0)
8856 /* Count the total number of FORALL index in the nested FORALL
8857 construct in order to allocate the VAR_EXPR with proper size. */
8858 total_var
= gfc_count_forall_iterators (code
);
8860 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8861 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
8864 /* The information about FORALL iterator, including FORALL index start, end
8865 and stride. The FORALL index can not appear in start, end or stride. */
8866 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8868 /* Check if any outer FORALL index name is the same as the current
8870 for (i
= 0; i
< nvar
; i
++)
8872 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8874 gfc_error ("An outer FORALL construct already has an index "
8875 "with this name %L", &fa
->var
->where
);
8879 /* Record the current FORALL index. */
8880 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8884 /* No memory leak. */
8885 gcc_assert (nvar
<= total_var
);
8888 /* Resolve the FORALL body. */
8889 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8891 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8892 gfc_resolve_blocks (code
->block
, ns
);
8896 /* Free only the VAR_EXPRs allocated in this frame. */
8897 for (i
= nvar
; i
< tmp
; i
++)
8898 gfc_free_expr (var_expr
[i
]);
8902 /* We are in the outermost FORALL construct. */
8903 gcc_assert (forall_save
== 0);
8905 /* VAR_EXPR is not needed any more. */
8912 /* Resolve a BLOCK construct statement. */
8915 resolve_block_construct (gfc_code
* code
)
8917 /* Resolve the BLOCK's namespace. */
8918 gfc_resolve (code
->ext
.block
.ns
);
8920 /* For an ASSOCIATE block, the associations (and their targets) are already
8921 resolved during resolve_symbol. */
8925 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8928 static void resolve_code (gfc_code
*, gfc_namespace
*);
8931 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8935 for (; b
; b
= b
->block
)
8937 t
= gfc_resolve_expr (b
->expr1
);
8938 if (!gfc_resolve_expr (b
->expr2
))
8944 if (t
&& b
->expr1
!= NULL
8945 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8946 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8953 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8954 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8959 resolve_branch (b
->label1
, b
);
8963 resolve_block_construct (b
);
8967 case EXEC_SELECT_TYPE
:
8971 case EXEC_DO_CONCURRENT
:
8979 case EXEC_OMP_ATOMIC
:
8980 case EXEC_OMP_CRITICAL
:
8982 case EXEC_OMP_MASTER
:
8983 case EXEC_OMP_ORDERED
:
8984 case EXEC_OMP_PARALLEL
:
8985 case EXEC_OMP_PARALLEL_DO
:
8986 case EXEC_OMP_PARALLEL_SECTIONS
:
8987 case EXEC_OMP_PARALLEL_WORKSHARE
:
8988 case EXEC_OMP_SECTIONS
:
8989 case EXEC_OMP_SINGLE
:
8991 case EXEC_OMP_TASKWAIT
:
8992 case EXEC_OMP_TASKYIELD
:
8993 case EXEC_OMP_WORKSHARE
:
8997 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9000 resolve_code (b
->next
, ns
);
9005 /* Does everything to resolve an ordinary assignment. Returns true
9006 if this is an interface assignment. */
9008 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9017 symbol_attribute attr
;
9019 if (gfc_extend_assign (code
, ns
))
9023 if (code
->op
== EXEC_ASSIGN_CALL
)
9025 lhs
= code
->ext
.actual
->expr
;
9026 rhsptr
= &code
->ext
.actual
->next
->expr
;
9030 gfc_actual_arglist
* args
;
9031 gfc_typebound_proc
* tbp
;
9033 gcc_assert (code
->op
== EXEC_COMPCALL
);
9035 args
= code
->expr1
->value
.compcall
.actual
;
9037 rhsptr
= &args
->next
->expr
;
9039 tbp
= code
->expr1
->value
.compcall
.tbp
;
9040 gcc_assert (!tbp
->is_generic
);
9043 /* Make a temporary rhs when there is a default initializer
9044 and rhs is the same symbol as the lhs. */
9045 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9046 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9047 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9048 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9049 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9058 && !gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9059 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9063 /* Handle the case of a BOZ literal on the RHS. */
9064 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9067 if (gfc_option
.warn_surprising
)
9068 gfc_warning ("BOZ literal at %L is bitwise transferred "
9069 "non-integer symbol '%s'", &code
->loc
,
9070 lhs
->symtree
->n
.sym
->name
);
9072 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9074 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9076 if (rc
== ARITH_UNDERFLOW
)
9077 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9078 ". This check can be disabled with the option "
9079 "-fno-range-check", &rhs
->where
);
9080 else if (rc
== ARITH_OVERFLOW
)
9081 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9082 ". This check can be disabled with the option "
9083 "-fno-range-check", &rhs
->where
);
9084 else if (rc
== ARITH_NAN
)
9085 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9086 ". This check can be disabled with the option "
9087 "-fno-range-check", &rhs
->where
);
9092 if (lhs
->ts
.type
== BT_CHARACTER
9093 && gfc_option
.warn_character_truncation
)
9095 if (lhs
->ts
.u
.cl
!= NULL
9096 && lhs
->ts
.u
.cl
->length
!= NULL
9097 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9098 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9100 if (rhs
->expr_type
== EXPR_CONSTANT
)
9101 rlen
= rhs
->value
.character
.length
;
9103 else if (rhs
->ts
.u
.cl
!= NULL
9104 && rhs
->ts
.u
.cl
->length
!= NULL
9105 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9106 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9108 if (rlen
&& llen
&& rlen
> llen
)
9109 gfc_warning_now ("CHARACTER expression will be truncated "
9110 "in assignment (%d/%d) at %L",
9111 llen
, rlen
, &code
->loc
);
9114 /* Ensure that a vector index expression for the lvalue is evaluated
9115 to a temporary if the lvalue symbol is referenced in it. */
9118 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9119 if (ref
->type
== REF_ARRAY
)
9121 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9122 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9123 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9124 ref
->u
.ar
.start
[n
]))
9126 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9130 if (gfc_pure (NULL
))
9132 if (lhs
->ts
.type
== BT_DERIVED
9133 && lhs
->expr_type
== EXPR_VARIABLE
9134 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9135 && rhs
->expr_type
== EXPR_VARIABLE
9136 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9137 || gfc_is_coindexed (rhs
)))
9140 if (gfc_is_coindexed (rhs
))
9141 gfc_error ("Coindexed expression at %L is assigned to "
9142 "a derived type variable with a POINTER "
9143 "component in a PURE procedure",
9146 gfc_error ("The impure variable at %L is assigned to "
9147 "a derived type variable with a POINTER "
9148 "component in a PURE procedure (12.6)",
9153 /* Fortran 2008, C1283. */
9154 if (gfc_is_coindexed (lhs
))
9156 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9157 "procedure", &rhs
->where
);
9162 if (gfc_implicit_pure (NULL
))
9164 if (lhs
->expr_type
== EXPR_VARIABLE
9165 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9166 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9167 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9169 if (lhs
->ts
.type
== BT_DERIVED
9170 && lhs
->expr_type
== EXPR_VARIABLE
9171 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9172 && rhs
->expr_type
== EXPR_VARIABLE
9173 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9174 || gfc_is_coindexed (rhs
)))
9175 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9177 /* Fortran 2008, C1283. */
9178 if (gfc_is_coindexed (lhs
))
9179 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9182 /* F2008, 7.2.1.2. */
9183 attr
= gfc_expr_attr (lhs
);
9184 if (lhs
->ts
.type
== BT_CLASS
&& attr
.allocatable
)
9186 if (attr
.codimension
)
9188 gfc_error ("Assignment to polymorphic coarray at %L is not "
9189 "permitted", &lhs
->where
);
9192 if (!gfc_notify_std (GFC_STD_F2008
, "Assignment to an allocatable "
9193 "polymorphic variable at %L", &lhs
->where
))
9195 if (!gfc_option
.flag_realloc_lhs
)
9197 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9198 "requires -frealloc-lhs", &lhs
->where
);
9202 gfc_error ("Assignment to an allocatable polymorphic variable at %L "
9203 "is not yet supported", &lhs
->where
);
9206 else if (lhs
->ts
.type
== BT_CLASS
)
9208 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
9209 "assignment at %L - check that there is a matching specific "
9210 "subroutine for '=' operator", &lhs
->where
);
9214 /* F2008, Section 7.2.1.2. */
9215 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9217 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9218 "component in assignment at %L", &lhs
->where
);
9222 gfc_check_assign (lhs
, rhs
, 1);
9227 /* Add a component reference onto an expression. */
9230 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9235 ref
= &((*ref
)->next
);
9236 *ref
= gfc_get_ref ();
9237 (*ref
)->type
= REF_COMPONENT
;
9238 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9239 (*ref
)->u
.c
.component
= c
;
9242 /* Add a full array ref, as necessary. */
9245 gfc_add_full_array_ref (e
, c
->as
);
9246 e
->rank
= c
->as
->rank
;
9251 /* Build an assignment. Keep the argument 'op' for future use, so that
9252 pointer assignments can be made. */
9255 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9256 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9258 gfc_code
*this_code
;
9260 this_code
= gfc_get_code (op
);
9261 this_code
->next
= NULL
;
9262 this_code
->expr1
= gfc_copy_expr (expr1
);
9263 this_code
->expr2
= gfc_copy_expr (expr2
);
9264 this_code
->loc
= loc
;
9267 add_comp_ref (this_code
->expr1
, comp1
);
9268 add_comp_ref (this_code
->expr2
, comp2
);
9275 /* Makes a temporary variable expression based on the characteristics of
9276 a given variable expression. */
9279 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9281 static int serial
= 0;
9282 char name
[GFC_MAX_SYMBOL_LEN
];
9285 gfc_array_ref
*aref
;
9288 sprintf (name
, GFC_PREFIX("DA%d"), serial
++);
9289 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9290 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9296 /* This function could be expanded to support other expression type
9297 but this is not needed here. */
9298 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9300 /* Obtain the arrayspec for the temporary. */
9303 aref
= gfc_find_array_ref (e
);
9304 if (e
->expr_type
== EXPR_VARIABLE
9305 && e
->symtree
->n
.sym
->as
== aref
->as
)
9309 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9310 if (ref
->type
== REF_COMPONENT
9311 && ref
->u
.c
.component
->as
== aref
->as
)
9319 /* Add the attributes and the arrayspec to the temporary. */
9320 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9321 tmp
->n
.sym
->attr
.function
= 0;
9322 tmp
->n
.sym
->attr
.result
= 0;
9323 tmp
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
9327 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9330 if (as
->type
== AS_DEFERRED
)
9331 tmp
->n
.sym
->attr
.allocatable
= 1;
9334 tmp
->n
.sym
->attr
.dimension
= 0;
9336 gfc_set_sym_referenced (tmp
->n
.sym
);
9337 gfc_commit_symbol (tmp
->n
.sym
);
9338 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9340 /* Should the lhs be a section, use its array ref for the
9341 temporary expression. */
9342 if (aref
&& aref
->type
!= AR_FULL
)
9344 gfc_free_ref_list (e
->ref
);
9345 e
->ref
= gfc_copy_ref (ref
);
9351 /* Add one line of code to the code chain, making sure that 'head' and
9352 'tail' are appropriately updated. */
9355 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9357 gcc_assert (this_code
);
9359 *head
= *tail
= *this_code
;
9361 *tail
= gfc_append_code (*tail
, *this_code
);
9366 /* Counts the potential number of part array references that would
9367 result from resolution of typebound defined assignments. */
9370 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9373 int c_depth
= 0, t_depth
;
9375 for (c
= derived
->components
; c
; c
= c
->next
)
9377 if ((c
->ts
.type
!= BT_DERIVED
9379 || c
->attr
.allocatable
9380 || c
->attr
.proc_pointer_comp
9381 || c
->attr
.class_pointer
9382 || c
->attr
.proc_pointer
)
9383 && !c
->attr
.defined_assign_comp
)
9386 if (c
->as
&& c_depth
== 0)
9389 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9390 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9395 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9397 return depth
+ c_depth
;
9401 /* Implement 7.2.1.3 of the F08 standard:
9402 "An intrinsic assignment where the variable is of derived type is
9403 performed as if each component of the variable were assigned from the
9404 corresponding component of expr using pointer assignment (7.2.2) for
9405 each pointer component, defined assignment for each nonpointer
9406 nonallocatable component of a type that has a type-bound defined
9407 assignment consistent with the component, intrinsic assignment for
9408 each other nonpointer nonallocatable component, ..."
9410 The pointer assignments are taken care of by the intrinsic
9411 assignment of the structure itself. This function recursively adds
9412 defined assignments where required. The recursion is accomplished
9413 by calling resolve_code.
9415 When the lhs in a defined assignment has intent INOUT, we need a
9416 temporary for the lhs. In pseudo-code:
9418 ! Only call function lhs once.
9419 if (lhs is not a constant or an variable)
9422 ! Do the intrinsic assignment
9424 ! Now do the defined assignments
9425 do over components with typebound defined assignment [%cmp]
9426 #if one component's assignment procedure is INOUT
9428 #if expr2 non-variable
9434 t1%cmp {defined=} expr2%cmp
9440 expr1%cmp {defined=} expr2%cmp
9444 /* The temporary assignments have to be put on top of the additional
9445 code to avoid the result being changed by the intrinsic assignment.
9447 static int component_assignment_level
= 0;
9448 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9451 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9453 gfc_component
*comp1
, *comp2
;
9454 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9456 int error_count
, depth
;
9458 gfc_get_errors (NULL
, &error_count
);
9460 /* Filter out continuing processing after an error. */
9462 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9463 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9466 /* TODO: Handle more than one part array reference in assignments. */
9467 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9468 (*code
)->expr1
->rank
? 1 : 0);
9471 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9472 "done because multiple part array references would "
9473 "occur in intermediate expressions.", &(*code
)->loc
);
9477 component_assignment_level
++;
9479 /* Create a temporary so that functions get called only once. */
9480 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9481 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9485 /* Assign the rhs to the temporary. */
9486 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9487 this_code
= build_assignment (EXEC_ASSIGN
,
9488 tmp_expr
, (*code
)->expr2
,
9489 NULL
, NULL
, (*code
)->loc
);
9490 /* Add the code and substitute the rhs expression. */
9491 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9492 gfc_free_expr ((*code
)->expr2
);
9493 (*code
)->expr2
= tmp_expr
;
9496 /* Do the intrinsic assignment. This is not needed if the lhs is one
9497 of the temporaries generated here, since the intrinsic assignment
9498 to the final result already does this. */
9499 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9501 this_code
= build_assignment (EXEC_ASSIGN
,
9502 (*code
)->expr1
, (*code
)->expr2
,
9503 NULL
, NULL
, (*code
)->loc
);
9504 add_code_to_chain (&this_code
, &head
, &tail
);
9507 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9508 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9511 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9515 /* The intrinsic assignment does the right thing for pointers
9516 of all kinds and allocatable components. */
9517 if (comp1
->ts
.type
!= BT_DERIVED
9518 || comp1
->attr
.pointer
9519 || comp1
->attr
.allocatable
9520 || comp1
->attr
.proc_pointer_comp
9521 || comp1
->attr
.class_pointer
9522 || comp1
->attr
.proc_pointer
)
9525 /* Make an assigment for this component. */
9526 this_code
= build_assignment (EXEC_ASSIGN
,
9527 (*code
)->expr1
, (*code
)->expr2
,
9528 comp1
, comp2
, (*code
)->loc
);
9530 /* Convert the assignment if there is a defined assignment for
9531 this type. Otherwise, using the call from resolve_code,
9532 recurse into its components. */
9533 resolve_code (this_code
, ns
);
9535 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9537 gfc_formal_arglist
*dummy_args
;
9539 /* Check that there is a typebound defined assignment. If not,
9540 then this must be a module defined assignment. We cannot
9541 use the defined_assign_comp attribute here because it must
9542 be this derived type that has the defined assignment and not
9544 if (!(comp1
->ts
.u
.derived
->f2k_derived
9545 && comp1
->ts
.u
.derived
->f2k_derived
9546 ->tb_op
[INTRINSIC_ASSIGN
]))
9548 gfc_free_statements (this_code
);
9553 /* If the first argument of the subroutine has intent INOUT
9554 a temporary must be generated and used instead. */
9555 rsym
= this_code
->resolved_sym
;
9556 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9558 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9560 gfc_code
*temp_code
;
9563 /* Build the temporary required for the assignment and put
9564 it at the head of the generated code. */
9567 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9568 temp_code
= build_assignment (EXEC_ASSIGN
,
9570 NULL
, NULL
, (*code
)->loc
);
9572 /* For allocatable LHS, check whether it is allocated. Note
9573 that allocatable components with defined assignment are
9574 not yet support. See PR 57696. */
9575 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
)
9579 gfc_lval_expr_from_sym ((*code
)->expr1
->symtree
->n
.sym
);
9580 block
= gfc_get_code (EXEC_IF
);
9581 block
->block
= gfc_get_code (EXEC_IF
);
9583 = gfc_build_intrinsic_call (ns
,
9584 GFC_ISYM_ALLOCATED
, "allocated",
9585 (*code
)->loc
, 1, e
);
9586 block
->block
->next
= temp_code
;
9589 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9592 /* Replace the first actual arg with the component of the
9594 gfc_free_expr (this_code
->ext
.actual
->expr
);
9595 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9596 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
9598 /* If the LHS variable is allocatable and wasn't allocated and
9599 the temporary is allocatable, pointer assign the address of
9600 the freshly allocated LHS to the temporary. */
9601 if ((*code
)->expr1
->symtree
->n
.sym
->attr
.allocatable
9602 && gfc_expr_attr ((*code
)->expr1
).allocatable
)
9606 cond
= gfc_get_expr ();
9607 cond
->ts
.type
= BT_LOGICAL
;
9608 cond
->ts
.kind
= gfc_default_logical_kind
;
9609 cond
->expr_type
= EXPR_OP
;
9610 cond
->where
= (*code
)->loc
;
9611 cond
->value
.op
.op
= INTRINSIC_NOT
;
9612 cond
->value
.op
.op1
= gfc_build_intrinsic_call (ns
,
9613 GFC_ISYM_ALLOCATED
, "allocated",
9614 (*code
)->loc
, 1, gfc_copy_expr (t1
));
9615 block
= gfc_get_code (EXEC_IF
);
9616 block
->block
= gfc_get_code (EXEC_IF
);
9617 block
->block
->expr1
= cond
;
9618 block
->block
->next
= build_assignment (EXEC_POINTER_ASSIGN
,
9620 NULL
, NULL
, (*code
)->loc
);
9621 add_code_to_chain (&block
, &head
, &tail
);
9625 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
9627 /* Don't add intrinsic assignments since they are already
9628 effected by the intrinsic assignment of the structure. */
9629 gfc_free_statements (this_code
);
9634 add_code_to_chain (&this_code
, &head
, &tail
);
9638 /* Transfer the value to the final result. */
9639 this_code
= build_assignment (EXEC_ASSIGN
,
9641 comp1
, comp2
, (*code
)->loc
);
9642 add_code_to_chain (&this_code
, &head
, &tail
);
9646 /* This is probably not necessary. */
9649 gfc_free_statements (this_code
);
9653 /* Put the temporary assignments at the top of the generated code. */
9654 if (tmp_head
&& component_assignment_level
== 1)
9656 gfc_append_code (tmp_head
, head
);
9658 tmp_head
= tmp_tail
= NULL
;
9661 /* Now attach the remaining code chain to the input code. Step on
9662 to the end of the new code since resolution is complete. */
9663 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
9664 tail
->next
= (*code
)->next
;
9665 /* Overwrite 'code' because this would place the intrinsic assignment
9666 before the temporary for the lhs is created. */
9667 gfc_free_expr ((*code
)->expr1
);
9668 gfc_free_expr ((*code
)->expr2
);
9673 component_assignment_level
--;
9677 /* Given a block of code, recursively resolve everything pointed to by this
9681 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9683 int omp_workshare_save
;
9684 int forall_save
, do_concurrent_save
;
9688 frame
.prev
= cs_base
;
9692 find_reachable_labels (code
);
9694 for (; code
; code
= code
->next
)
9696 frame
.current
= code
;
9697 forall_save
= forall_flag
;
9698 do_concurrent_save
= gfc_do_concurrent_flag
;
9700 if (code
->op
== EXEC_FORALL
)
9703 gfc_resolve_forall (code
, ns
, forall_save
);
9706 else if (code
->block
)
9708 omp_workshare_save
= -1;
9711 case EXEC_OMP_PARALLEL_WORKSHARE
:
9712 omp_workshare_save
= omp_workshare_flag
;
9713 omp_workshare_flag
= 1;
9714 gfc_resolve_omp_parallel_blocks (code
, ns
);
9716 case EXEC_OMP_PARALLEL
:
9717 case EXEC_OMP_PARALLEL_DO
:
9718 case EXEC_OMP_PARALLEL_SECTIONS
:
9720 omp_workshare_save
= omp_workshare_flag
;
9721 omp_workshare_flag
= 0;
9722 gfc_resolve_omp_parallel_blocks (code
, ns
);
9725 gfc_resolve_omp_do_blocks (code
, ns
);
9727 case EXEC_SELECT_TYPE
:
9728 /* Blocks are handled in resolve_select_type because we have
9729 to transform the SELECT TYPE into ASSOCIATE first. */
9731 case EXEC_DO_CONCURRENT
:
9732 gfc_do_concurrent_flag
= 1;
9733 gfc_resolve_blocks (code
->block
, ns
);
9734 gfc_do_concurrent_flag
= 2;
9736 case EXEC_OMP_WORKSHARE
:
9737 omp_workshare_save
= omp_workshare_flag
;
9738 omp_workshare_flag
= 1;
9741 gfc_resolve_blocks (code
->block
, ns
);
9745 if (omp_workshare_save
!= -1)
9746 omp_workshare_flag
= omp_workshare_save
;
9750 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9751 t
= gfc_resolve_expr (code
->expr1
);
9752 forall_flag
= forall_save
;
9753 gfc_do_concurrent_flag
= do_concurrent_save
;
9755 if (!gfc_resolve_expr (code
->expr2
))
9758 if (code
->op
== EXEC_ALLOCATE
9759 && !gfc_resolve_expr (code
->expr3
))
9765 case EXEC_END_BLOCK
:
9766 case EXEC_END_NESTED_BLOCK
:
9770 case EXEC_ERROR_STOP
:
9774 case EXEC_ASSIGN_CALL
:
9779 case EXEC_SYNC_IMAGES
:
9780 case EXEC_SYNC_MEMORY
:
9781 resolve_sync (code
);
9786 resolve_lock_unlock (code
);
9790 /* Keep track of which entry we are up to. */
9791 current_entry_id
= code
->ext
.entry
->id
;
9795 resolve_where (code
, NULL
);
9799 if (code
->expr1
!= NULL
)
9801 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9802 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9803 "INTEGER variable", &code
->expr1
->where
);
9804 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9805 gfc_error ("Variable '%s' has not been assigned a target "
9806 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9807 &code
->expr1
->where
);
9810 resolve_branch (code
->label1
, code
);
9814 if (code
->expr1
!= NULL
9815 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9816 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9817 "INTEGER return specifier", &code
->expr1
->where
);
9820 case EXEC_INIT_ASSIGN
:
9821 case EXEC_END_PROCEDURE
:
9828 if (!gfc_check_vardef_context (code
->expr1
, false, false, false,
9832 if (resolve_ordinary_assign (code
, ns
))
9834 if (code
->op
== EXEC_COMPCALL
)
9840 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
9841 if (code
->expr1
->ts
.type
== BT_DERIVED
9842 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
9843 generate_component_assignments (&code
, ns
);
9847 case EXEC_LABEL_ASSIGN
:
9848 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9849 gfc_error ("Label %d referenced at %L is never defined",
9850 code
->label1
->value
, &code
->label1
->where
);
9852 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9853 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9854 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9855 != gfc_default_integer_kind
9856 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9857 gfc_error ("ASSIGN statement at %L requires a scalar "
9858 "default INTEGER variable", &code
->expr1
->where
);
9861 case EXEC_POINTER_ASSIGN
:
9868 /* This is both a variable definition and pointer assignment
9869 context, so check both of them. For rank remapping, a final
9870 array ref may be present on the LHS and fool gfc_expr_attr
9871 used in gfc_check_vardef_context. Remove it. */
9872 e
= remove_last_array_ref (code
->expr1
);
9873 t
= gfc_check_vardef_context (e
, true, false, false,
9874 _("pointer assignment"));
9876 t
= gfc_check_vardef_context (e
, false, false, false,
9877 _("pointer assignment"));
9882 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9886 case EXEC_ARITHMETIC_IF
:
9888 && code
->expr1
->ts
.type
!= BT_INTEGER
9889 && code
->expr1
->ts
.type
!= BT_REAL
)
9890 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9891 "expression", &code
->expr1
->where
);
9893 resolve_branch (code
->label1
, code
);
9894 resolve_branch (code
->label2
, code
);
9895 resolve_branch (code
->label3
, code
);
9899 if (t
&& code
->expr1
!= NULL
9900 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9901 || code
->expr1
->rank
!= 0))
9902 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9903 &code
->expr1
->where
);
9908 resolve_call (code
);
9913 resolve_typebound_subroutine (code
);
9917 resolve_ppc_call (code
);
9921 /* Select is complicated. Also, a SELECT construct could be
9922 a transformed computed GOTO. */
9923 resolve_select (code
, false);
9926 case EXEC_SELECT_TYPE
:
9927 resolve_select_type (code
, ns
);
9931 resolve_block_construct (code
);
9935 if (code
->ext
.iterator
!= NULL
)
9937 gfc_iterator
*iter
= code
->ext
.iterator
;
9938 if (gfc_resolve_iterator (iter
, true, false))
9939 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9944 if (code
->expr1
== NULL
)
9945 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9947 && (code
->expr1
->rank
!= 0
9948 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9949 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9950 "a scalar LOGICAL expression", &code
->expr1
->where
);
9955 resolve_allocate_deallocate (code
, "ALLOCATE");
9959 case EXEC_DEALLOCATE
:
9961 resolve_allocate_deallocate (code
, "DEALLOCATE");
9966 if (!gfc_resolve_open (code
->ext
.open
))
9969 resolve_branch (code
->ext
.open
->err
, code
);
9973 if (!gfc_resolve_close (code
->ext
.close
))
9976 resolve_branch (code
->ext
.close
->err
, code
);
9979 case EXEC_BACKSPACE
:
9983 if (!gfc_resolve_filepos (code
->ext
.filepos
))
9986 resolve_branch (code
->ext
.filepos
->err
, code
);
9990 if (!gfc_resolve_inquire (code
->ext
.inquire
))
9993 resolve_branch (code
->ext
.inquire
->err
, code
);
9997 gcc_assert (code
->ext
.inquire
!= NULL
);
9998 if (!gfc_resolve_inquire (code
->ext
.inquire
))
10001 resolve_branch (code
->ext
.inquire
->err
, code
);
10005 if (!gfc_resolve_wait (code
->ext
.wait
))
10008 resolve_branch (code
->ext
.wait
->err
, code
);
10009 resolve_branch (code
->ext
.wait
->end
, code
);
10010 resolve_branch (code
->ext
.wait
->eor
, code
);
10015 if (!gfc_resolve_dt (code
->ext
.dt
, &code
->loc
))
10018 resolve_branch (code
->ext
.dt
->err
, code
);
10019 resolve_branch (code
->ext
.dt
->end
, code
);
10020 resolve_branch (code
->ext
.dt
->eor
, code
);
10023 case EXEC_TRANSFER
:
10024 resolve_transfer (code
);
10027 case EXEC_DO_CONCURRENT
:
10029 resolve_forall_iterators (code
->ext
.forall_iterator
);
10031 if (code
->expr1
!= NULL
10032 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10033 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10034 "expression", &code
->expr1
->where
);
10037 case EXEC_OMP_ATOMIC
:
10038 case EXEC_OMP_BARRIER
:
10039 case EXEC_OMP_CRITICAL
:
10040 case EXEC_OMP_FLUSH
:
10042 case EXEC_OMP_MASTER
:
10043 case EXEC_OMP_ORDERED
:
10044 case EXEC_OMP_SECTIONS
:
10045 case EXEC_OMP_SINGLE
:
10046 case EXEC_OMP_TASKWAIT
:
10047 case EXEC_OMP_TASKYIELD
:
10048 case EXEC_OMP_WORKSHARE
:
10049 gfc_resolve_omp_directive (code
, ns
);
10052 case EXEC_OMP_PARALLEL
:
10053 case EXEC_OMP_PARALLEL_DO
:
10054 case EXEC_OMP_PARALLEL_SECTIONS
:
10055 case EXEC_OMP_PARALLEL_WORKSHARE
:
10056 case EXEC_OMP_TASK
:
10057 omp_workshare_save
= omp_workshare_flag
;
10058 omp_workshare_flag
= 0;
10059 gfc_resolve_omp_directive (code
, ns
);
10060 omp_workshare_flag
= omp_workshare_save
;
10064 gfc_internal_error ("resolve_code(): Bad statement code");
10068 cs_base
= frame
.prev
;
10072 /* Resolve initial values and make sure they are compatible with
10076 resolve_values (gfc_symbol
*sym
)
10080 if (sym
->value
== NULL
)
10083 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10084 t
= resolve_structure_cons (sym
->value
, 1);
10086 t
= gfc_resolve_expr (sym
->value
);
10091 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10095 /* Verify any BIND(C) derived types in the namespace so we can report errors
10096 for them once, rather than for each variable declared of that type. */
10099 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10101 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10102 && derived_sym
->attr
.is_bind_c
== 1)
10103 verify_bind_c_derived_type (derived_sym
);
10109 /* Verify that any binding labels used in a given namespace do not collide
10110 with the names or binding labels of any global symbols. Multiple INTERFACE
10111 for the same procedure are permitted. */
10114 gfc_verify_binding_labels (gfc_symbol
*sym
)
10117 const char *module
;
10119 if (!sym
|| !sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
10120 || sym
->attr
.flavor
== FL_DERIVED
|| !sym
->binding_label
)
10123 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10126 module
= sym
->module
;
10127 else if (sym
->ns
&& sym
->ns
->proc_name
10128 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
10129 module
= sym
->ns
->proc_name
->name
;
10130 else if (sym
->ns
&& sym
->ns
->parent
10131 && sym
->ns
&& sym
->ns
->parent
->proc_name
10132 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10133 module
= sym
->ns
->parent
->proc_name
->name
;
10139 && (gsym
->type
== GSYM_FUNCTION
|| gsym
->type
== GSYM_SUBROUTINE
)))
10142 gsym
= gfc_get_gsymbol (sym
->binding_label
);
10143 gsym
->where
= sym
->declared_at
;
10144 gsym
->sym_name
= sym
->name
;
10145 gsym
->binding_label
= sym
->binding_label
;
10146 gsym
->binding_label
= sym
->binding_label
;
10147 gsym
->ns
= sym
->ns
;
10148 gsym
->mod_name
= module
;
10149 if (sym
->attr
.function
)
10150 gsym
->type
= GSYM_FUNCTION
;
10151 else if (sym
->attr
.subroutine
)
10152 gsym
->type
= GSYM_SUBROUTINE
;
10153 /* Mark as variable/procedure as defined, unless its an INTERFACE. */
10154 gsym
->defined
= sym
->attr
.if_source
!= IFSRC_IFBODY
;
10158 if (sym
->attr
.flavor
== FL_VARIABLE
&& gsym
->type
!= GSYM_UNKNOWN
)
10160 gfc_error ("Variable %s with binding label %s at %L uses the same global "
10161 "identifier as entity at %L", sym
->name
,
10162 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10163 /* Clear the binding label to prevent checking multiple times. */
10164 sym
->binding_label
= NULL
;
10167 else if (sym
->attr
.flavor
== FL_VARIABLE
10168 && (strcmp (module
, gsym
->mod_name
) != 0
10169 || strcmp (sym
->name
, gsym
->sym_name
) != 0))
10171 /* This can only happen if the variable is defined in a module - if it
10172 isn't the same module, reject it. */
10173 gfc_error ("Variable %s from module %s with binding label %s at %L uses "
10174 "the same global identifier as entity at %L from module %s",
10175 sym
->name
, module
, sym
->binding_label
,
10176 &sym
->declared_at
, &gsym
->where
, gsym
->mod_name
);
10177 sym
->binding_label
= NULL
;
10179 else if ((sym
->attr
.function
|| sym
->attr
.subroutine
)
10180 && ((gsym
->type
!= GSYM_SUBROUTINE
&& gsym
->type
!= GSYM_FUNCTION
)
10181 || (gsym
->defined
&& sym
->attr
.if_source
!= IFSRC_IFBODY
))
10182 && sym
!= gsym
->ns
->proc_name
10183 && (strcmp (gsym
->sym_name
, sym
->name
) != 0
10184 || module
!= gsym
->mod_name
10185 || (module
&& strcmp (module
, gsym
->mod_name
) != 0)))
10187 /* Print an error if the procdure is defined multiple times; we have to
10188 exclude references to the same procedure via module association or
10189 multiple checks for the same procedure. */
10190 gfc_error ("Procedure %s with binding label %s at %L uses the same "
10191 "global identifier as entity at %L", sym
->name
,
10192 sym
->binding_label
, &sym
->declared_at
, &gsym
->where
);
10193 sym
->binding_label
= NULL
;
10198 /* Resolve an index expression. */
10201 resolve_index_expr (gfc_expr
*e
)
10203 if (!gfc_resolve_expr (e
))
10206 if (!gfc_simplify_expr (e
, 0))
10209 if (!gfc_specification_expr (e
))
10216 /* Resolve a charlen structure. */
10219 resolve_charlen (gfc_charlen
*cl
)
10222 bool saved_specification_expr
;
10228 saved_specification_expr
= specification_expr
;
10229 specification_expr
= true;
10231 if (cl
->length_from_typespec
)
10233 if (!gfc_resolve_expr (cl
->length
))
10235 specification_expr
= saved_specification_expr
;
10239 if (!gfc_simplify_expr (cl
->length
, 0))
10241 specification_expr
= saved_specification_expr
;
10248 if (!resolve_index_expr (cl
->length
))
10250 specification_expr
= saved_specification_expr
;
10255 /* "If the character length parameter value evaluates to a negative
10256 value, the length of character entities declared is zero." */
10257 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10259 if (gfc_option
.warn_surprising
)
10260 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10261 " the length has been set to zero",
10262 &cl
->length
->where
, i
);
10263 gfc_replace_expr (cl
->length
,
10264 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10267 /* Check that the character length is not too large. */
10268 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10269 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10270 && cl
->length
->ts
.type
== BT_INTEGER
10271 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10273 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10274 specification_expr
= saved_specification_expr
;
10278 specification_expr
= saved_specification_expr
;
10283 /* Test for non-constant shape arrays. */
10286 is_non_constant_shape_array (gfc_symbol
*sym
)
10292 not_constant
= false;
10293 if (sym
->as
!= NULL
)
10295 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10296 has not been simplified; parameter array references. Do the
10297 simplification now. */
10298 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10300 e
= sym
->as
->lower
[i
];
10301 if (e
&& (!resolve_index_expr(e
)
10302 || !gfc_is_constant_expr (e
)))
10303 not_constant
= true;
10304 e
= sym
->as
->upper
[i
];
10305 if (e
&& (!resolve_index_expr(e
)
10306 || !gfc_is_constant_expr (e
)))
10307 not_constant
= true;
10310 return not_constant
;
10313 /* Given a symbol and an initialization expression, add code to initialize
10314 the symbol to the function entry. */
10316 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10320 gfc_namespace
*ns
= sym
->ns
;
10322 /* Search for the function namespace if this is a contained
10323 function without an explicit result. */
10324 if (sym
->attr
.function
&& sym
== sym
->result
10325 && sym
->name
!= sym
->ns
->proc_name
->name
)
10327 ns
= ns
->contained
;
10328 for (;ns
; ns
= ns
->sibling
)
10329 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10335 gfc_free_expr (init
);
10339 /* Build an l-value expression for the result. */
10340 lval
= gfc_lval_expr_from_sym (sym
);
10342 /* Add the code at scope entry. */
10343 init_st
= gfc_get_code (EXEC_INIT_ASSIGN
);
10344 init_st
->next
= ns
->code
;
10345 ns
->code
= init_st
;
10347 /* Assign the default initializer to the l-value. */
10348 init_st
->loc
= sym
->declared_at
;
10349 init_st
->expr1
= lval
;
10350 init_st
->expr2
= init
;
10353 /* Assign the default initializer to a derived type variable or result. */
10356 apply_default_init (gfc_symbol
*sym
)
10358 gfc_expr
*init
= NULL
;
10360 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10363 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10364 init
= gfc_default_initializer (&sym
->ts
);
10366 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10369 build_init_assign (sym
, init
);
10370 sym
->attr
.referenced
= 1;
10373 /* Build an initializer for a local integer, real, complex, logical, or
10374 character variable, based on the command line flags finit-local-zero,
10375 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10376 null if the symbol should not have a default initialization. */
10378 build_default_init_expr (gfc_symbol
*sym
)
10381 gfc_expr
*init_expr
;
10384 /* These symbols should never have a default initialization. */
10385 if (sym
->attr
.allocatable
10386 || sym
->attr
.external
10388 || sym
->attr
.pointer
10389 || sym
->attr
.in_equivalence
10390 || sym
->attr
.in_common
10393 || sym
->attr
.cray_pointee
10394 || sym
->attr
.cray_pointer
10398 /* Now we'll try to build an initializer expression. */
10399 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10400 &sym
->declared_at
);
10402 /* We will only initialize integers, reals, complex, logicals, and
10403 characters, and only if the corresponding command-line flags
10404 were set. Otherwise, we free init_expr and return null. */
10405 switch (sym
->ts
.type
)
10408 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10409 mpz_set_si (init_expr
->value
.integer
,
10410 gfc_option
.flag_init_integer_value
);
10413 gfc_free_expr (init_expr
);
10419 switch (gfc_option
.flag_init_real
)
10421 case GFC_INIT_REAL_SNAN
:
10422 init_expr
->is_snan
= 1;
10423 /* Fall through. */
10424 case GFC_INIT_REAL_NAN
:
10425 mpfr_set_nan (init_expr
->value
.real
);
10428 case GFC_INIT_REAL_INF
:
10429 mpfr_set_inf (init_expr
->value
.real
, 1);
10432 case GFC_INIT_REAL_NEG_INF
:
10433 mpfr_set_inf (init_expr
->value
.real
, -1);
10436 case GFC_INIT_REAL_ZERO
:
10437 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10441 gfc_free_expr (init_expr
);
10448 switch (gfc_option
.flag_init_real
)
10450 case GFC_INIT_REAL_SNAN
:
10451 init_expr
->is_snan
= 1;
10452 /* Fall through. */
10453 case GFC_INIT_REAL_NAN
:
10454 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10455 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10458 case GFC_INIT_REAL_INF
:
10459 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10460 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10463 case GFC_INIT_REAL_NEG_INF
:
10464 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10465 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10468 case GFC_INIT_REAL_ZERO
:
10469 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10473 gfc_free_expr (init_expr
);
10480 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10481 init_expr
->value
.logical
= 0;
10482 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10483 init_expr
->value
.logical
= 1;
10486 gfc_free_expr (init_expr
);
10492 /* For characters, the length must be constant in order to
10493 create a default initializer. */
10494 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10495 && sym
->ts
.u
.cl
->length
10496 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10498 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10499 init_expr
->value
.character
.length
= char_len
;
10500 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10501 for (i
= 0; i
< char_len
; i
++)
10502 init_expr
->value
.character
.string
[i
]
10503 = (unsigned char) gfc_option
.flag_init_character_value
;
10507 gfc_free_expr (init_expr
);
10510 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10511 && sym
->ts
.u
.cl
->length
)
10513 gfc_actual_arglist
*arg
;
10514 init_expr
= gfc_get_expr ();
10515 init_expr
->where
= sym
->declared_at
;
10516 init_expr
->ts
= sym
->ts
;
10517 init_expr
->expr_type
= EXPR_FUNCTION
;
10518 init_expr
->value
.function
.isym
=
10519 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10520 init_expr
->value
.function
.name
= "repeat";
10521 arg
= gfc_get_actual_arglist ();
10522 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10524 arg
->expr
->value
.character
.string
[0]
10525 = gfc_option
.flag_init_character_value
;
10526 arg
->next
= gfc_get_actual_arglist ();
10527 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10528 init_expr
->value
.function
.actual
= arg
;
10533 gfc_free_expr (init_expr
);
10539 /* Add an initialization expression to a local variable. */
10541 apply_default_init_local (gfc_symbol
*sym
)
10543 gfc_expr
*init
= NULL
;
10545 /* The symbol should be a variable or a function return value. */
10546 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10547 || (sym
->attr
.function
&& sym
->result
!= sym
))
10550 /* Try to build the initializer expression. If we can't initialize
10551 this symbol, then init will be NULL. */
10552 init
= build_default_init_expr (sym
);
10556 /* For saved variables, we don't want to add an initializer at function
10557 entry, so we just add a static initializer. Note that automatic variables
10558 are stack allocated even with -fno-automatic; we have also to exclude
10559 result variable, which are also nonstatic. */
10560 if (sym
->attr
.save
|| sym
->ns
->save_all
10561 || (gfc_option
.flag_max_stack_var_size
== 0 && !sym
->attr
.result
10562 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10564 /* Don't clobber an existing initializer! */
10565 gcc_assert (sym
->value
== NULL
);
10570 build_init_assign (sym
, init
);
10574 /* Resolution of common features of flavors variable and procedure. */
10577 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10579 gfc_array_spec
*as
;
10581 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10582 as
= CLASS_DATA (sym
)->as
;
10586 /* Constraints on deferred shape variable. */
10587 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10589 bool pointer
, allocatable
, dimension
;
10591 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10593 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10594 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10595 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10599 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
10600 allocatable
= sym
->attr
.allocatable
;
10601 dimension
= sym
->attr
.dimension
;
10606 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10608 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10609 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10612 else if (!gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10613 "'%s' at %L may not be ALLOCATABLE",
10614 sym
->name
, &sym
->declared_at
))
10618 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10620 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10621 "assumed rank", sym
->name
, &sym
->declared_at
);
10627 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10628 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10630 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10631 sym
->name
, &sym
->declared_at
);
10636 /* Constraints on polymorphic variables. */
10637 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10640 if (sym
->attr
.class_ok
10641 && !sym
->attr
.select_type_temporary
10642 && !UNLIMITED_POLY (sym
)
10643 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10645 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10646 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10647 &sym
->declared_at
);
10652 /* Assume that use associated symbols were checked in the module ns.
10653 Class-variables that are associate-names are also something special
10654 and excepted from the test. */
10655 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10657 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10658 "or pointer", sym
->name
, &sym
->declared_at
);
10667 /* Additional checks for symbols with flavor variable and derived
10668 type. To be called from resolve_fl_variable. */
10671 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10673 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10675 /* Check to see if a derived type is blocked from being host
10676 associated by the presence of another class I symbol in the same
10677 namespace. 14.6.1.3 of the standard and the discussion on
10678 comp.lang.fortran. */
10679 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10680 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10683 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10684 if (s
&& s
->attr
.generic
)
10685 s
= gfc_find_dt_in_generic (s
);
10686 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10688 gfc_error ("The type '%s' cannot be host associated at %L "
10689 "because it is blocked by an incompatible object "
10690 "of the same name declared at %L",
10691 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10697 /* 4th constraint in section 11.3: "If an object of a type for which
10698 component-initialization is specified (R429) appears in the
10699 specification-part of a module and does not have the ALLOCATABLE
10700 or POINTER attribute, the object shall have the SAVE attribute."
10702 The check for initializers is performed with
10703 gfc_has_default_initializer because gfc_default_initializer generates
10704 a hidden default for allocatable components. */
10705 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10706 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10707 && !sym
->ns
->save_all
&& !sym
->attr
.save
10708 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10709 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10710 && !gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for module variable "
10711 "'%s' at %L, needed due to the default "
10712 "initialization", sym
->name
, &sym
->declared_at
))
10715 /* Assign default initializer. */
10716 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10717 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10719 sym
->value
= gfc_default_initializer (&sym
->ts
);
10726 /* Resolve symbols with flavor variable. */
10729 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10731 int no_init_flag
, automatic_flag
;
10733 const char *auto_save_msg
;
10734 bool saved_specification_expr
;
10736 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10739 if (!resolve_fl_var_and_proc (sym
, mp_flag
))
10742 /* Set this flag to check that variables are parameters of all entries.
10743 This check is effected by the call to gfc_resolve_expr through
10744 is_non_constant_shape_array. */
10745 saved_specification_expr
= specification_expr
;
10746 specification_expr
= true;
10748 if (sym
->ns
->proc_name
10749 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10750 || sym
->ns
->proc_name
->attr
.is_main_program
)
10751 && !sym
->attr
.use_assoc
10752 && !sym
->attr
.allocatable
10753 && !sym
->attr
.pointer
10754 && is_non_constant_shape_array (sym
))
10756 /* The shape of a main program or module array needs to be
10758 gfc_error ("The module or main program array '%s' at %L must "
10759 "have constant shape", sym
->name
, &sym
->declared_at
);
10760 specification_expr
= saved_specification_expr
;
10764 /* Constraints on deferred type parameter. */
10765 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10767 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10768 "requires either the pointer or allocatable attribute",
10769 sym
->name
, &sym
->declared_at
);
10770 specification_expr
= saved_specification_expr
;
10774 if (sym
->ts
.type
== BT_CHARACTER
)
10776 /* Make sure that character string variables with assumed length are
10777 dummy arguments. */
10778 e
= sym
->ts
.u
.cl
->length
;
10779 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10780 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
10782 gfc_error ("Entity with assumed character length at %L must be a "
10783 "dummy argument or a PARAMETER", &sym
->declared_at
);
10784 specification_expr
= saved_specification_expr
;
10788 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10790 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10791 specification_expr
= saved_specification_expr
;
10795 if (!gfc_is_constant_expr (e
)
10796 && !(e
->expr_type
== EXPR_VARIABLE
10797 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10799 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10800 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10801 || sym
->ns
->proc_name
->attr
.is_main_program
))
10803 gfc_error ("'%s' at %L must have constant character length "
10804 "in this context", sym
->name
, &sym
->declared_at
);
10805 specification_expr
= saved_specification_expr
;
10808 if (sym
->attr
.in_common
)
10810 gfc_error ("COMMON variable '%s' at %L must have constant "
10811 "character length", sym
->name
, &sym
->declared_at
);
10812 specification_expr
= saved_specification_expr
;
10818 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10819 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10821 /* Determine if the symbol may not have an initializer. */
10822 no_init_flag
= automatic_flag
= 0;
10823 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10824 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10826 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10827 && is_non_constant_shape_array (sym
))
10829 no_init_flag
= automatic_flag
= 1;
10831 /* Also, they must not have the SAVE attribute.
10832 SAVE_IMPLICIT is checked below. */
10833 if (sym
->as
&& sym
->attr
.codimension
)
10835 int corank
= sym
->as
->corank
;
10836 sym
->as
->corank
= 0;
10837 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10838 sym
->as
->corank
= corank
;
10840 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10842 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10843 specification_expr
= saved_specification_expr
;
10848 /* Ensure that any initializer is simplified. */
10850 gfc_simplify_expr (sym
->value
, 1);
10852 /* Reject illegal initializers. */
10853 if (!sym
->mark
&& sym
->value
)
10855 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10856 && CLASS_DATA (sym
)->attr
.allocatable
))
10857 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10858 sym
->name
, &sym
->declared_at
);
10859 else if (sym
->attr
.external
)
10860 gfc_error ("External '%s' at %L cannot have an initializer",
10861 sym
->name
, &sym
->declared_at
);
10862 else if (sym
->attr
.dummy
10863 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10864 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10865 sym
->name
, &sym
->declared_at
);
10866 else if (sym
->attr
.intrinsic
)
10867 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10868 sym
->name
, &sym
->declared_at
);
10869 else if (sym
->attr
.result
)
10870 gfc_error ("Function result '%s' at %L cannot have an initializer",
10871 sym
->name
, &sym
->declared_at
);
10872 else if (automatic_flag
)
10873 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10874 sym
->name
, &sym
->declared_at
);
10876 goto no_init_error
;
10877 specification_expr
= saved_specification_expr
;
10882 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10884 bool res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10885 specification_expr
= saved_specification_expr
;
10889 specification_expr
= saved_specification_expr
;
10894 /* Resolve a procedure. */
10897 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10899 gfc_formal_arglist
*arg
;
10901 if (sym
->attr
.function
10902 && !resolve_fl_var_and_proc (sym
, mp_flag
))
10905 if (sym
->ts
.type
== BT_CHARACTER
)
10907 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10909 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10910 && !resolve_charlen (cl
))
10913 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10914 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10916 gfc_error ("Character-valued statement function '%s' at %L must "
10917 "have constant length", sym
->name
, &sym
->declared_at
);
10922 /* Ensure that derived type for are not of a private type. Internal
10923 module procedures are excluded by 2.2.3.3 - i.e., they are not
10924 externally accessible and can access all the objects accessible in
10926 if (!(sym
->ns
->parent
10927 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10928 && gfc_check_symbol_access (sym
))
10930 gfc_interface
*iface
;
10932 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
10935 && arg
->sym
->ts
.type
== BT_DERIVED
10936 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10937 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10938 && !gfc_notify_std (GFC_STD_F2003
, "'%s' is of a PRIVATE type "
10939 "and cannot be a dummy argument"
10940 " of '%s', which is PUBLIC at %L",
10941 arg
->sym
->name
, sym
->name
,
10942 &sym
->declared_at
))
10944 /* Stop this message from recurring. */
10945 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10950 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10951 PRIVATE to the containing module. */
10952 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10954 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10957 && arg
->sym
->ts
.type
== BT_DERIVED
10958 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10959 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10960 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10961 "PUBLIC interface '%s' at %L "
10962 "takes dummy arguments of '%s' which "
10963 "is PRIVATE", iface
->sym
->name
,
10964 sym
->name
, &iface
->sym
->declared_at
,
10965 gfc_typename(&arg
->sym
->ts
)))
10967 /* Stop this message from recurring. */
10968 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10974 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10975 PRIVATE to the containing module. */
10976 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10978 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
10981 && arg
->sym
->ts
.type
== BT_DERIVED
10982 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10983 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10984 && !gfc_notify_std (GFC_STD_F2003
, "Procedure '%s' in "
10985 "PUBLIC interface '%s' at %L takes "
10986 "dummy arguments of '%s' which is "
10987 "PRIVATE", iface
->sym
->name
,
10988 sym
->name
, &iface
->sym
->declared_at
,
10989 gfc_typename(&arg
->sym
->ts
)))
10991 /* Stop this message from recurring. */
10992 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10999 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11000 && !sym
->attr
.proc_pointer
)
11002 gfc_error ("Function '%s' at %L cannot have an initializer",
11003 sym
->name
, &sym
->declared_at
);
11007 /* An external symbol may not have an initializer because it is taken to be
11008 a procedure. Exception: Procedure Pointers. */
11009 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11011 gfc_error ("External object '%s' at %L may not have an initializer",
11012 sym
->name
, &sym
->declared_at
);
11016 /* An elemental function is required to return a scalar 12.7.1 */
11017 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11019 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11020 "result", sym
->name
, &sym
->declared_at
);
11021 /* Reset so that the error only occurs once. */
11022 sym
->attr
.elemental
= 0;
11026 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11027 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11029 gfc_error ("Statement function '%s' at %L may not have pointer or "
11030 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11034 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11035 char-len-param shall not be array-valued, pointer-valued, recursive
11036 or pure. ....snip... A character value of * may only be used in the
11037 following ways: (i) Dummy arg of procedure - dummy associates with
11038 actual length; (ii) To declare a named constant; or (iii) External
11039 function - but length must be declared in calling scoping unit. */
11040 if (sym
->attr
.function
11041 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11042 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11044 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11045 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11047 if (sym
->as
&& sym
->as
->rank
)
11048 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11049 "array-valued", sym
->name
, &sym
->declared_at
);
11051 if (sym
->attr
.pointer
)
11052 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11053 "pointer-valued", sym
->name
, &sym
->declared_at
);
11055 if (sym
->attr
.pure
)
11056 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11057 "pure", sym
->name
, &sym
->declared_at
);
11059 if (sym
->attr
.recursive
)
11060 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11061 "recursive", sym
->name
, &sym
->declared_at
);
11066 /* Appendix B.2 of the standard. Contained functions give an
11067 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11068 character length is an F2003 feature. */
11069 if (!sym
->attr
.contained
11070 && gfc_current_form
!= FORM_FIXED
11071 && !sym
->ts
.deferred
)
11072 gfc_notify_std (GFC_STD_F95_OBS
,
11073 "CHARACTER(*) function '%s' at %L",
11074 sym
->name
, &sym
->declared_at
);
11077 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11079 gfc_formal_arglist
*curr_arg
;
11080 int has_non_interop_arg
= 0;
11082 if (!verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11083 sym
->common_block
))
11085 /* Clear these to prevent looking at them again if there was an
11087 sym
->attr
.is_bind_c
= 0;
11088 sym
->attr
.is_c_interop
= 0;
11089 sym
->ts
.is_c_interop
= 0;
11093 /* So far, no errors have been found. */
11094 sym
->attr
.is_c_interop
= 1;
11095 sym
->ts
.is_c_interop
= 1;
11098 curr_arg
= gfc_sym_get_dummy_args (sym
);
11099 while (curr_arg
!= NULL
)
11101 /* Skip implicitly typed dummy args here. */
11102 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11103 if (!gfc_verify_c_interop_param (curr_arg
->sym
))
11104 /* If something is found to fail, record the fact so we
11105 can mark the symbol for the procedure as not being
11106 BIND(C) to try and prevent multiple errors being
11108 has_non_interop_arg
= 1;
11110 curr_arg
= curr_arg
->next
;
11113 /* See if any of the arguments were not interoperable and if so, clear
11114 the procedure symbol to prevent duplicate error messages. */
11115 if (has_non_interop_arg
!= 0)
11117 sym
->attr
.is_c_interop
= 0;
11118 sym
->ts
.is_c_interop
= 0;
11119 sym
->attr
.is_bind_c
= 0;
11123 if (!sym
->attr
.proc_pointer
)
11125 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11127 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11128 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11131 if (sym
->attr
.intent
)
11133 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11134 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11137 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11139 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11140 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11143 if (sym
->attr
.external
&& sym
->attr
.function
11144 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11145 || sym
->attr
.contained
))
11147 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11148 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11151 if (strcmp ("ppr@", sym
->name
) == 0)
11153 gfc_error ("Procedure pointer result '%s' at %L "
11154 "is missing the pointer attribute",
11155 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11164 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11165 been defined and we now know their defined arguments, check that they fulfill
11166 the requirements of the standard for procedures used as finalizers. */
11169 gfc_resolve_finalizers (gfc_symbol
* derived
)
11171 gfc_finalizer
* list
;
11172 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11173 bool result
= true;
11174 bool seen_scalar
= false;
11176 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11179 /* Walk over the list of finalizer-procedures, check them, and if any one
11180 does not fit in with the standard's definition, print an error and remove
11181 it from the list. */
11182 prev_link
= &derived
->f2k_derived
->finalizers
;
11183 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11185 gfc_formal_arglist
*dummy_args
;
11190 /* Skip this finalizer if we already resolved it. */
11191 if (list
->proc_tree
)
11193 prev_link
= &(list
->next
);
11197 /* Check this exists and is a SUBROUTINE. */
11198 if (!list
->proc_sym
->attr
.subroutine
)
11200 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11201 list
->proc_sym
->name
, &list
->where
);
11205 /* We should have exactly one argument. */
11206 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11207 if (!dummy_args
|| dummy_args
->next
)
11209 gfc_error ("FINAL procedure at %L must have exactly one argument",
11213 arg
= dummy_args
->sym
;
11215 /* This argument must be of our type. */
11216 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11218 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11219 &arg
->declared_at
, derived
->name
);
11223 /* It must neither be a pointer nor allocatable nor optional. */
11224 if (arg
->attr
.pointer
)
11226 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11227 &arg
->declared_at
);
11230 if (arg
->attr
.allocatable
)
11232 gfc_error ("Argument of FINAL procedure at %L must not be"
11233 " ALLOCATABLE", &arg
->declared_at
);
11236 if (arg
->attr
.optional
)
11238 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11239 &arg
->declared_at
);
11243 /* It must not be INTENT(OUT). */
11244 if (arg
->attr
.intent
== INTENT_OUT
)
11246 gfc_error ("Argument of FINAL procedure at %L must not be"
11247 " INTENT(OUT)", &arg
->declared_at
);
11251 /* Warn if the procedure is non-scalar and not assumed shape. */
11252 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11253 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11254 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11255 " shape argument", &arg
->declared_at
);
11257 /* Check that it does not match in kind and rank with a FINAL procedure
11258 defined earlier. To really loop over the *earlier* declarations,
11259 we need to walk the tail of the list as new ones were pushed at the
11261 /* TODO: Handle kind parameters once they are implemented. */
11262 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11263 for (i
= list
->next
; i
; i
= i
->next
)
11265 gfc_formal_arglist
*dummy_args
;
11267 /* Argument list might be empty; that is an error signalled earlier,
11268 but we nevertheless continued resolving. */
11269 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11272 gfc_symbol
* i_arg
= dummy_args
->sym
;
11273 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11274 if (i_rank
== my_rank
)
11276 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11277 " rank (%d) as '%s'",
11278 list
->proc_sym
->name
, &list
->where
, my_rank
,
11279 i
->proc_sym
->name
);
11285 /* Is this the/a scalar finalizer procedure? */
11286 if (!arg
->as
|| arg
->as
->rank
== 0)
11287 seen_scalar
= true;
11289 /* Find the symtree for this procedure. */
11290 gcc_assert (!list
->proc_tree
);
11291 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11293 prev_link
= &list
->next
;
11296 /* Remove wrong nodes immediately from the list so we don't risk any
11297 troubles in the future when they might fail later expectations. */
11301 *prev_link
= list
->next
;
11302 gfc_free_finalizer (i
);
11305 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11306 were nodes in the list, must have been for arrays. It is surely a good
11307 idea to have a scalar version there if there's something to finalize. */
11308 if (gfc_option
.warn_surprising
&& result
&& !seen_scalar
)
11309 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11310 " defined at %L, suggest also scalar one",
11311 derived
->name
, &derived
->declared_at
);
11313 gfc_find_derived_vtab (derived
);
11318 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11321 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11322 const char* generic_name
, locus where
)
11324 gfc_symbol
*sym1
, *sym2
;
11325 const char *pass1
, *pass2
;
11327 gcc_assert (t1
->specific
&& t2
->specific
);
11328 gcc_assert (!t1
->specific
->is_generic
);
11329 gcc_assert (!t2
->specific
->is_generic
);
11330 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11332 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11333 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11338 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11339 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11340 || sym1
->attr
.function
!= sym2
->attr
.function
)
11342 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11343 " GENERIC '%s' at %L",
11344 sym1
->name
, sym2
->name
, generic_name
, &where
);
11348 /* Compare the interfaces. */
11349 if (t1
->specific
->nopass
)
11351 else if (t1
->specific
->pass_arg
)
11352 pass1
= t1
->specific
->pass_arg
;
11354 pass1
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11355 if (t2
->specific
->nopass
)
11357 else if (t2
->specific
->pass_arg
)
11358 pass2
= t2
->specific
->pass_arg
;
11360 pass2
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11361 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11362 NULL
, 0, pass1
, pass2
))
11364 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11365 sym1
->name
, sym2
->name
, generic_name
, &where
);
11373 /* Worker function for resolving a generic procedure binding; this is used to
11374 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11376 The difference between those cases is finding possible inherited bindings
11377 that are overridden, as one has to look for them in tb_sym_root,
11378 tb_uop_root or tb_op, respectively. Thus the caller must already find
11379 the super-type and set p->overridden correctly. */
11382 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11383 gfc_typebound_proc
* p
, const char* name
)
11385 gfc_tbp_generic
* target
;
11386 gfc_symtree
* first_target
;
11387 gfc_symtree
* inherited
;
11389 gcc_assert (p
&& p
->is_generic
);
11391 /* Try to find the specific bindings for the symtrees in our target-list. */
11392 gcc_assert (p
->u
.generic
);
11393 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11394 if (!target
->specific
)
11396 gfc_typebound_proc
* overridden_tbp
;
11397 gfc_tbp_generic
* g
;
11398 const char* target_name
;
11400 target_name
= target
->specific_st
->name
;
11402 /* Defined for this type directly. */
11403 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11405 target
->specific
= target
->specific_st
->n
.tb
;
11406 goto specific_found
;
11409 /* Look for an inherited specific binding. */
11412 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11417 gcc_assert (inherited
->n
.tb
);
11418 target
->specific
= inherited
->n
.tb
;
11419 goto specific_found
;
11423 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11424 " at %L", target_name
, name
, &p
->where
);
11427 /* Once we've found the specific binding, check it is not ambiguous with
11428 other specifics already found or inherited for the same GENERIC. */
11430 gcc_assert (target
->specific
);
11432 /* This must really be a specific binding! */
11433 if (target
->specific
->is_generic
)
11435 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11436 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11440 /* Check those already resolved on this type directly. */
11441 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11442 if (g
!= target
&& g
->specific
11443 && !check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11446 /* Check for ambiguity with inherited specific targets. */
11447 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11448 overridden_tbp
= overridden_tbp
->overridden
)
11449 if (overridden_tbp
->is_generic
)
11451 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11453 gcc_assert (g
->specific
);
11454 if (!check_generic_tbp_ambiguity (target
, g
, name
, p
->where
))
11460 /* If we attempt to "overwrite" a specific binding, this is an error. */
11461 if (p
->overridden
&& !p
->overridden
->is_generic
)
11463 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11464 " the same name", name
, &p
->where
);
11468 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11469 all must have the same attributes here. */
11470 first_target
= p
->u
.generic
->specific
->u
.specific
;
11471 gcc_assert (first_target
);
11472 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11473 p
->function
= first_target
->n
.sym
->attr
.function
;
11479 /* Resolve a GENERIC procedure binding for a derived type. */
11482 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11484 gfc_symbol
* super_type
;
11486 /* Find the overridden binding if any. */
11487 st
->n
.tb
->overridden
= NULL
;
11488 super_type
= gfc_get_derived_super_type (derived
);
11491 gfc_symtree
* overridden
;
11492 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11495 if (overridden
&& overridden
->n
.tb
)
11496 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11499 /* Resolve using worker function. */
11500 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11504 /* Retrieve the target-procedure of an operator binding and do some checks in
11505 common for intrinsic and user-defined type-bound operators. */
11508 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11510 gfc_symbol
* target_proc
;
11512 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11513 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11514 gcc_assert (target_proc
);
11516 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11517 if (target
->specific
->nopass
)
11519 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11523 return target_proc
;
11527 /* Resolve a type-bound intrinsic operator. */
11530 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11531 gfc_typebound_proc
* p
)
11533 gfc_symbol
* super_type
;
11534 gfc_tbp_generic
* target
;
11536 /* If there's already an error here, do nothing (but don't fail again). */
11540 /* Operators should always be GENERIC bindings. */
11541 gcc_assert (p
->is_generic
);
11543 /* Look for an overridden binding. */
11544 super_type
= gfc_get_derived_super_type (derived
);
11545 if (super_type
&& super_type
->f2k_derived
)
11546 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11549 p
->overridden
= NULL
;
11551 /* Resolve general GENERIC properties using worker function. */
11552 if (!resolve_tb_generic_targets (super_type
, p
, gfc_op2string(op
)))
11555 /* Check the targets to be procedures of correct interface. */
11556 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11558 gfc_symbol
* target_proc
;
11560 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11564 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11567 /* Add target to non-typebound operator list. */
11568 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11569 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11571 gfc_interface
*head
, *intr
;
11572 if (!gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
, p
->where
))
11574 head
= derived
->ns
->op
[op
];
11575 intr
= gfc_get_interface ();
11576 intr
->sym
= target_proc
;
11577 intr
->where
= p
->where
;
11579 derived
->ns
->op
[op
] = intr
;
11591 /* Resolve a type-bound user operator (tree-walker callback). */
11593 static gfc_symbol
* resolve_bindings_derived
;
11594 static bool resolve_bindings_result
;
11596 static bool check_uop_procedure (gfc_symbol
* sym
, locus where
);
11599 resolve_typebound_user_op (gfc_symtree
* stree
)
11601 gfc_symbol
* super_type
;
11602 gfc_tbp_generic
* target
;
11604 gcc_assert (stree
&& stree
->n
.tb
);
11606 if (stree
->n
.tb
->error
)
11609 /* Operators should always be GENERIC bindings. */
11610 gcc_assert (stree
->n
.tb
->is_generic
);
11612 /* Find overridden procedure, if any. */
11613 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11614 if (super_type
&& super_type
->f2k_derived
)
11616 gfc_symtree
* overridden
;
11617 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11618 stree
->name
, true, NULL
);
11620 if (overridden
&& overridden
->n
.tb
)
11621 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11624 stree
->n
.tb
->overridden
= NULL
;
11626 /* Resolve basically using worker function. */
11627 if (!resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
))
11630 /* Check the targets to be functions of correct interface. */
11631 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11633 gfc_symbol
* target_proc
;
11635 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11639 if (!check_uop_procedure (target_proc
, stree
->n
.tb
->where
))
11646 resolve_bindings_result
= false;
11647 stree
->n
.tb
->error
= 1;
11651 /* Resolve the type-bound procedures for a derived type. */
11654 resolve_typebound_procedure (gfc_symtree
* stree
)
11658 gfc_symbol
* me_arg
;
11659 gfc_symbol
* super_type
;
11660 gfc_component
* comp
;
11662 gcc_assert (stree
);
11664 /* Undefined specific symbol from GENERIC target definition. */
11668 if (stree
->n
.tb
->error
)
11671 /* If this is a GENERIC binding, use that routine. */
11672 if (stree
->n
.tb
->is_generic
)
11674 if (!resolve_typebound_generic (resolve_bindings_derived
, stree
))
11679 /* Get the target-procedure to check it. */
11680 gcc_assert (!stree
->n
.tb
->is_generic
);
11681 gcc_assert (stree
->n
.tb
->u
.specific
);
11682 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11683 where
= stree
->n
.tb
->where
;
11685 /* Default access should already be resolved from the parser. */
11686 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11688 if (stree
->n
.tb
->deferred
)
11690 if (!check_proc_interface (proc
, &where
))
11695 /* Check for F08:C465. */
11696 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11697 || (proc
->attr
.proc
!= PROC_MODULE
11698 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11699 || proc
->attr
.abstract
)
11701 gfc_error ("'%s' must be a module procedure or an external procedure with"
11702 " an explicit interface at %L", proc
->name
, &where
);
11707 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11708 stree
->n
.tb
->function
= proc
->attr
.function
;
11710 /* Find the super-type of the current derived type. We could do this once and
11711 store in a global if speed is needed, but as long as not I believe this is
11712 more readable and clearer. */
11713 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11715 /* If PASS, resolve and check arguments if not already resolved / loaded
11716 from a .mod file. */
11717 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11719 gfc_formal_arglist
*dummy_args
;
11721 dummy_args
= gfc_sym_get_dummy_args (proc
);
11722 if (stree
->n
.tb
->pass_arg
)
11724 gfc_formal_arglist
*i
;
11726 /* If an explicit passing argument name is given, walk the arg-list
11727 and look for it. */
11730 stree
->n
.tb
->pass_arg_num
= 1;
11731 for (i
= dummy_args
; i
; i
= i
->next
)
11733 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11738 ++stree
->n
.tb
->pass_arg_num
;
11743 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11745 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11746 stree
->n
.tb
->pass_arg
);
11752 /* Otherwise, take the first one; there should in fact be at least
11754 stree
->n
.tb
->pass_arg_num
= 1;
11757 gfc_error ("Procedure '%s' with PASS at %L must have at"
11758 " least one argument", proc
->name
, &where
);
11761 me_arg
= dummy_args
->sym
;
11764 /* Now check that the argument-type matches and the passed-object
11765 dummy argument is generally fine. */
11767 gcc_assert (me_arg
);
11769 if (me_arg
->ts
.type
!= BT_CLASS
)
11771 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11772 " at %L", proc
->name
, &where
);
11776 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11777 != resolve_bindings_derived
)
11779 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11780 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11781 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11785 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11786 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11788 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11789 " scalar", proc
->name
, &where
);
11792 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11794 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11795 " be ALLOCATABLE", proc
->name
, &where
);
11798 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11800 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11801 " be POINTER", proc
->name
, &where
);
11806 /* If we are extending some type, check that we don't override a procedure
11807 flagged NON_OVERRIDABLE. */
11808 stree
->n
.tb
->overridden
= NULL
;
11811 gfc_symtree
* overridden
;
11812 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11813 stree
->name
, true, NULL
);
11817 if (overridden
->n
.tb
)
11818 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11820 if (!gfc_check_typebound_override (stree
, overridden
))
11825 /* See if there's a name collision with a component directly in this type. */
11826 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11827 if (!strcmp (comp
->name
, stree
->name
))
11829 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11831 stree
->name
, &where
, resolve_bindings_derived
->name
);
11835 /* Try to find a name collision with an inherited component. */
11836 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11838 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11839 " component of '%s'",
11840 stree
->name
, &where
, resolve_bindings_derived
->name
);
11844 stree
->n
.tb
->error
= 0;
11848 resolve_bindings_result
= false;
11849 stree
->n
.tb
->error
= 1;
11854 resolve_typebound_procedures (gfc_symbol
* derived
)
11857 gfc_symbol
* super_type
;
11859 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11862 super_type
= gfc_get_derived_super_type (derived
);
11864 resolve_symbol (super_type
);
11866 resolve_bindings_derived
= derived
;
11867 resolve_bindings_result
= true;
11869 /* Make sure the vtab has been generated. */
11870 gfc_find_derived_vtab (derived
);
11872 if (derived
->f2k_derived
->tb_sym_root
)
11873 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11874 &resolve_typebound_procedure
);
11876 if (derived
->f2k_derived
->tb_uop_root
)
11877 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11878 &resolve_typebound_user_op
);
11880 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11882 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11883 if (p
&& !resolve_typebound_intrinsic_op (derived
,
11884 (gfc_intrinsic_op
)op
, p
))
11885 resolve_bindings_result
= false;
11888 return resolve_bindings_result
;
11892 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11893 to give all identical derived types the same backend_decl. */
11895 add_dt_to_dt_list (gfc_symbol
*derived
)
11897 gfc_dt_list
*dt_list
;
11899 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11900 if (derived
== dt_list
->derived
)
11903 dt_list
= gfc_get_dt_list ();
11904 dt_list
->next
= gfc_derived_types
;
11905 dt_list
->derived
= derived
;
11906 gfc_derived_types
= dt_list
;
11910 /* Ensure that a derived-type is really not abstract, meaning that every
11911 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11914 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11919 if (!ensure_not_abstract_walker (sub
, st
->left
))
11921 if (!ensure_not_abstract_walker (sub
, st
->right
))
11924 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11926 gfc_symtree
* overriding
;
11927 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11930 gcc_assert (overriding
->n
.tb
);
11931 if (overriding
->n
.tb
->deferred
)
11933 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11934 " '%s' is DEFERRED and not overridden",
11935 sub
->name
, &sub
->declared_at
, st
->name
);
11944 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11946 /* The algorithm used here is to recursively travel up the ancestry of sub
11947 and for each ancestor-type, check all bindings. If any of them is
11948 DEFERRED, look it up starting from sub and see if the found (overriding)
11949 binding is not DEFERRED.
11950 This is not the most efficient way to do this, but it should be ok and is
11951 clearer than something sophisticated. */
11953 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11955 if (!ancestor
->attr
.abstract
)
11958 /* Walk bindings of this ancestor. */
11959 if (ancestor
->f2k_derived
)
11962 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11967 /* Find next ancestor type and recurse on it. */
11968 ancestor
= gfc_get_derived_super_type (ancestor
);
11970 return ensure_not_abstract (sub
, ancestor
);
11976 /* This check for typebound defined assignments is done recursively
11977 since the order in which derived types are resolved is not always in
11978 order of the declarations. */
11981 check_defined_assignments (gfc_symbol
*derived
)
11985 for (c
= derived
->components
; c
; c
= c
->next
)
11987 if (c
->ts
.type
!= BT_DERIVED
11989 || c
->attr
.allocatable
11990 || c
->attr
.proc_pointer_comp
11991 || c
->attr
.class_pointer
11992 || c
->attr
.proc_pointer
)
11995 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
11996 || (c
->ts
.u
.derived
->f2k_derived
11997 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
11999 derived
->attr
.defined_assign_comp
= 1;
12003 check_defined_assignments (c
->ts
.u
.derived
);
12004 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12006 derived
->attr
.defined_assign_comp
= 1;
12013 /* Resolve the components of a derived type. This does not have to wait until
12014 resolution stage, but can be done as soon as the dt declaration has been
12018 resolve_fl_derived0 (gfc_symbol
*sym
)
12020 gfc_symbol
* super_type
;
12023 if (sym
->attr
.unlimited_polymorphic
)
12026 super_type
= gfc_get_derived_super_type (sym
);
12029 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12031 gfc_error ("As extending type '%s' at %L has a coarray component, "
12032 "parent type '%s' shall also have one", sym
->name
,
12033 &sym
->declared_at
, super_type
->name
);
12037 /* Ensure the extended type gets resolved before we do. */
12038 if (super_type
&& !resolve_fl_derived0 (super_type
))
12041 /* An ABSTRACT type must be extensible. */
12042 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12044 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12045 sym
->name
, &sym
->declared_at
);
12049 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12052 for ( ; c
!= NULL
; c
= c
->next
)
12054 if (c
->attr
.artificial
)
12057 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12058 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
12060 gfc_error ("Deferred-length character component '%s' at %L is not "
12061 "yet supported", c
->name
, &c
->loc
);
12066 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12067 && c
->attr
.codimension
12068 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12070 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12071 "deferred shape", c
->name
, &c
->loc
);
12076 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12077 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12079 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12080 "shall not be a coarray", c
->name
, &c
->loc
);
12085 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12086 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12087 || c
->attr
.allocatable
))
12089 gfc_error ("Component '%s' at %L with coarray component "
12090 "shall be a nonpointer, nonallocatable scalar",
12096 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12098 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12099 "is not an array pointer", c
->name
, &c
->loc
);
12103 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12105 gfc_symbol
*ifc
= c
->ts
.interface
;
12107 if (!sym
->attr
.vtype
12108 && !check_proc_interface (ifc
, &c
->loc
))
12111 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12113 /* Resolve interface and copy attributes. */
12114 if (ifc
->formal
&& !ifc
->formal_ns
)
12115 resolve_symbol (ifc
);
12116 if (ifc
->attr
.intrinsic
)
12117 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12121 c
->ts
= ifc
->result
->ts
;
12122 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12123 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12124 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12125 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12126 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12131 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12132 c
->attr
.pointer
= ifc
->attr
.pointer
;
12133 c
->attr
.dimension
= ifc
->attr
.dimension
;
12134 c
->as
= gfc_copy_array_spec (ifc
->as
);
12135 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12137 c
->ts
.interface
= ifc
;
12138 c
->attr
.function
= ifc
->attr
.function
;
12139 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12141 c
->attr
.pure
= ifc
->attr
.pure
;
12142 c
->attr
.elemental
= ifc
->attr
.elemental
;
12143 c
->attr
.recursive
= ifc
->attr
.recursive
;
12144 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12145 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12146 /* Copy char length. */
12147 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12149 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12150 if (cl
->length
&& !cl
->resolved
12151 && !gfc_resolve_expr (cl
->length
))
12157 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12159 /* Since PPCs are not implicitly typed, a PPC without an explicit
12160 interface must be a subroutine. */
12161 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12164 /* Procedure pointer components: Check PASS arg. */
12165 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12166 && !sym
->attr
.vtype
)
12168 gfc_symbol
* me_arg
;
12170 if (c
->tb
->pass_arg
)
12172 gfc_formal_arglist
* i
;
12174 /* If an explicit passing argument name is given, walk the arg-list
12175 and look for it. */
12178 c
->tb
->pass_arg_num
= 1;
12179 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12181 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12186 c
->tb
->pass_arg_num
++;
12191 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12192 "at %L has no argument '%s'", c
->name
,
12193 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12200 /* Otherwise, take the first one; there should in fact be at least
12202 c
->tb
->pass_arg_num
= 1;
12203 if (!c
->ts
.interface
->formal
)
12205 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12206 "must have at least one argument",
12211 me_arg
= c
->ts
.interface
->formal
->sym
;
12214 /* Now check that the argument-type matches. */
12215 gcc_assert (me_arg
);
12216 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12217 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12218 || (me_arg
->ts
.type
== BT_CLASS
12219 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12221 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12222 " the derived type '%s'", me_arg
->name
, c
->name
,
12223 me_arg
->name
, &c
->loc
, sym
->name
);
12228 /* Check for C453. */
12229 if (me_arg
->attr
.dimension
)
12231 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12232 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12238 if (me_arg
->attr
.pointer
)
12240 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12241 "may not have the POINTER attribute", me_arg
->name
,
12242 c
->name
, me_arg
->name
, &c
->loc
);
12247 if (me_arg
->attr
.allocatable
)
12249 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12250 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12251 me_arg
->name
, &c
->loc
);
12256 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12257 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12258 " at %L", c
->name
, &c
->loc
);
12262 /* Check type-spec if this is not the parent-type component. */
12263 if (((sym
->attr
.is_class
12264 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12265 || c
!= sym
->components
->ts
.u
.derived
->components
))
12266 || (!sym
->attr
.is_class
12267 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12268 && !sym
->attr
.vtype
12269 && !resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
))
12272 /* If this type is an extension, set the accessibility of the parent
12275 && ((sym
->attr
.is_class
12276 && c
== sym
->components
->ts
.u
.derived
->components
)
12277 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12278 && strcmp (super_type
->name
, c
->name
) == 0)
12279 c
->attr
.access
= super_type
->attr
.access
;
12281 /* If this type is an extension, see if this component has the same name
12282 as an inherited type-bound procedure. */
12283 if (super_type
&& !sym
->attr
.is_class
12284 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12286 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12287 " inherited type-bound procedure",
12288 c
->name
, sym
->name
, &c
->loc
);
12292 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12293 && !c
->ts
.deferred
)
12295 if (c
->ts
.u
.cl
->length
== NULL
12296 || (!resolve_charlen(c
->ts
.u
.cl
))
12297 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12299 gfc_error ("Character length of component '%s' needs to "
12300 "be a constant specification expression at %L",
12302 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12307 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12308 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12310 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12311 "length must be a POINTER or ALLOCATABLE",
12312 c
->name
, sym
->name
, &c
->loc
);
12316 if (c
->ts
.type
== BT_DERIVED
12317 && sym
->component_access
!= ACCESS_PRIVATE
12318 && gfc_check_symbol_access (sym
)
12319 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12320 && !c
->ts
.u
.derived
->attr
.use_assoc
12321 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12322 && !gfc_notify_std (GFC_STD_F2003
, "the component '%s' is a "
12323 "PRIVATE type and cannot be a component of "
12324 "'%s', which is PUBLIC at %L", c
->name
,
12325 sym
->name
, &sym
->declared_at
))
12328 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12330 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12331 "type %s", c
->name
, &c
->loc
, sym
->name
);
12335 if (sym
->attr
.sequence
)
12337 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12339 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12340 "not have the SEQUENCE attribute",
12341 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12346 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12347 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12348 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12349 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12350 CLASS_DATA (c
)->ts
.u
.derived
12351 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12353 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12354 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12355 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12357 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12358 "that has not been declared", c
->name
, sym
->name
,
12363 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12364 && CLASS_DATA (c
)->attr
.class_pointer
12365 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12366 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12367 && !UNLIMITED_POLY (c
))
12369 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12370 "that has not been declared", c
->name
, sym
->name
,
12376 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12377 && (!c
->attr
.class_ok
12378 || !(CLASS_DATA (c
)->attr
.class_pointer
12379 || CLASS_DATA (c
)->attr
.allocatable
)))
12381 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12382 "or pointer", c
->name
, &c
->loc
);
12383 /* Prevent a recurrence of the error. */
12384 c
->ts
.type
= BT_UNKNOWN
;
12388 /* Ensure that all the derived type components are put on the
12389 derived type list; even in formal namespaces, where derived type
12390 pointer components might not have been declared. */
12391 if (c
->ts
.type
== BT_DERIVED
12393 && c
->ts
.u
.derived
->components
12395 && sym
!= c
->ts
.u
.derived
)
12396 add_dt_to_dt_list (c
->ts
.u
.derived
);
12398 if (!gfc_resolve_array_spec (c
->as
,
12399 !(c
->attr
.pointer
|| c
->attr
.proc_pointer
12400 || c
->attr
.allocatable
)))
12403 if (c
->initializer
&& !sym
->attr
.vtype
12404 && !gfc_check_assign_symbol (sym
, c
, c
->initializer
))
12408 check_defined_assignments (sym
);
12410 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12411 sym
->attr
.defined_assign_comp
12412 = super_type
->attr
.defined_assign_comp
;
12414 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12415 all DEFERRED bindings are overridden. */
12416 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12417 && !sym
->attr
.is_class
12418 && !ensure_not_abstract (sym
, super_type
))
12421 /* Add derived type to the derived type list. */
12422 add_dt_to_dt_list (sym
);
12424 /* Check if the type is finalizable. This is done in order to ensure that the
12425 finalization wrapper is generated early enough. */
12426 gfc_is_finalizable (sym
, NULL
);
12432 /* The following procedure does the full resolution of a derived type,
12433 including resolution of all type-bound procedures (if present). In contrast
12434 to 'resolve_fl_derived0' this can only be done after the module has been
12435 parsed completely. */
12438 resolve_fl_derived (gfc_symbol
*sym
)
12440 gfc_symbol
*gen_dt
= NULL
;
12442 if (sym
->attr
.unlimited_polymorphic
)
12445 if (!sym
->attr
.is_class
)
12446 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12447 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12448 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12449 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12450 && !gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of function "
12451 "'%s' at %L being the same name as derived "
12452 "type at %L", sym
->name
,
12453 gen_dt
->generic
->sym
== sym
12454 ? gen_dt
->generic
->next
->sym
->name
12455 : gen_dt
->generic
->sym
->name
,
12456 gen_dt
->generic
->sym
== sym
12457 ? &gen_dt
->generic
->next
->sym
->declared_at
12458 : &gen_dt
->generic
->sym
->declared_at
,
12459 &sym
->declared_at
))
12462 /* Resolve the finalizer procedures. */
12463 if (!gfc_resolve_finalizers (sym
))
12466 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12468 /* Fix up incomplete CLASS symbols. */
12469 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12470 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12472 /* Nothing more to do for unlimited polymorphic entities. */
12473 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12475 else if (vptr
->ts
.u
.derived
== NULL
)
12477 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12479 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12483 if (!resolve_fl_derived0 (sym
))
12486 /* Resolve the type-bound procedures. */
12487 if (!resolve_typebound_procedures (sym
))
12495 resolve_fl_namelist (gfc_symbol
*sym
)
12500 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12502 /* Check again, the check in match only works if NAMELIST comes
12504 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12506 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12507 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12511 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12512 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12513 "with assumed shape in namelist '%s' at %L",
12514 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12517 if (is_non_constant_shape_array (nl
->sym
)
12518 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
12519 "with nonconstant shape in namelist '%s' at %L",
12520 nl
->sym
->name
, sym
->name
, &sym
->declared_at
))
12523 if (nl
->sym
->ts
.type
== BT_CHARACTER
12524 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12525 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12526 && !gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' with "
12527 "nonconstant character length in "
12528 "namelist '%s' at %L", nl
->sym
->name
,
12529 sym
->name
, &sym
->declared_at
))
12532 /* FIXME: Once UDDTIO is implemented, the following can be
12534 if (nl
->sym
->ts
.type
== BT_CLASS
)
12536 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12537 "polymorphic and requires a defined input/output "
12538 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12542 if (nl
->sym
->ts
.type
== BT_DERIVED
12543 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12544 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12546 if (!gfc_notify_std (GFC_STD_F2003
, "NAMELIST object '%s' in "
12547 "namelist '%s' at %L with ALLOCATABLE "
12548 "or POINTER components", nl
->sym
->name
,
12549 sym
->name
, &sym
->declared_at
))
12552 /* FIXME: Once UDDTIO is implemented, the following can be
12554 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12555 "ALLOCATABLE or POINTER components and thus requires "
12556 "a defined input/output procedure", nl
->sym
->name
,
12557 sym
->name
, &sym
->declared_at
);
12562 /* Reject PRIVATE objects in a PUBLIC namelist. */
12563 if (gfc_check_symbol_access (sym
))
12565 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12567 if (!nl
->sym
->attr
.use_assoc
12568 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12569 && !gfc_check_symbol_access (nl
->sym
))
12571 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12572 "cannot be member of PUBLIC namelist '%s' at %L",
12573 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12577 /* Types with private components that came here by USE-association. */
12578 if (nl
->sym
->ts
.type
== BT_DERIVED
12579 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12581 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12582 "components and cannot be member of namelist '%s' at %L",
12583 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12587 /* Types with private components that are defined in the same module. */
12588 if (nl
->sym
->ts
.type
== BT_DERIVED
12589 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12590 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12592 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12593 "cannot be a member of PUBLIC namelist '%s' at %L",
12594 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12601 /* 14.1.2 A module or internal procedure represent local entities
12602 of the same type as a namelist member and so are not allowed. */
12603 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12605 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12608 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12609 if ((nl
->sym
== sym
->ns
->proc_name
)
12611 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12616 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12617 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12619 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12620 "attribute in '%s' at %L", nlsym
->name
,
12621 &sym
->declared_at
);
12631 resolve_fl_parameter (gfc_symbol
*sym
)
12633 /* A parameter array's shape needs to be constant. */
12634 if (sym
->as
!= NULL
12635 && (sym
->as
->type
== AS_DEFERRED
12636 || is_non_constant_shape_array (sym
)))
12638 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12639 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12643 /* Make sure a parameter that has been implicitly typed still
12644 matches the implicit type, since PARAMETER statements can precede
12645 IMPLICIT statements. */
12646 if (sym
->attr
.implicit_type
12647 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12650 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12651 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12655 /* Make sure the types of derived parameters are consistent. This
12656 type checking is deferred until resolution because the type may
12657 refer to a derived type from the host. */
12658 if (sym
->ts
.type
== BT_DERIVED
12659 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12661 gfc_error ("Incompatible derived type in PARAMETER at %L",
12662 &sym
->value
->where
);
12669 /* Do anything necessary to resolve a symbol. Right now, we just
12670 assume that an otherwise unknown symbol is a variable. This sort
12671 of thing commonly happens for symbols in module. */
12674 resolve_symbol (gfc_symbol
*sym
)
12676 int check_constant
, mp_flag
;
12677 gfc_symtree
*symtree
;
12678 gfc_symtree
*this_symtree
;
12681 symbol_attribute class_attr
;
12682 gfc_array_spec
*as
;
12683 bool saved_specification_expr
;
12689 if (sym
->attr
.artificial
)
12692 if (sym
->attr
.unlimited_polymorphic
)
12695 if (sym
->attr
.flavor
== FL_UNKNOWN
12696 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12697 && !sym
->attr
.generic
&& !sym
->attr
.external
12698 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12701 /* If we find that a flavorless symbol is an interface in one of the
12702 parent namespaces, find its symtree in this namespace, free the
12703 symbol and set the symtree to point to the interface symbol. */
12704 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12706 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12707 if (symtree
&& (symtree
->n
.sym
->generic
||
12708 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12709 && sym
->ns
->construct_entities
)))
12711 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12713 gfc_release_symbol (sym
);
12714 symtree
->n
.sym
->refs
++;
12715 this_symtree
->n
.sym
= symtree
->n
.sym
;
12720 /* Otherwise give it a flavor according to such attributes as
12722 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12723 && sym
->attr
.intrinsic
== 0)
12724 sym
->attr
.flavor
= FL_VARIABLE
;
12725 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12727 sym
->attr
.flavor
= FL_PROCEDURE
;
12728 if (sym
->attr
.dimension
)
12729 sym
->attr
.function
= 1;
12733 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12734 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12736 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12737 && !resolve_procedure_interface (sym
))
12740 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12741 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12743 if (sym
->attr
.external
)
12744 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12745 "at %L", &sym
->declared_at
);
12747 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12748 "at %L", &sym
->declared_at
);
12753 if (sym
->attr
.flavor
== FL_DERIVED
&& !resolve_fl_derived (sym
))
12756 /* Symbols that are module procedures with results (functions) have
12757 the types and array specification copied for type checking in
12758 procedures that call them, as well as for saving to a module
12759 file. These symbols can't stand the scrutiny that their results
12761 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12763 /* Make sure that the intrinsic is consistent with its internal
12764 representation. This needs to be done before assigning a default
12765 type to avoid spurious warnings. */
12766 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12767 && !gfc_resolve_intrinsic (sym
, &sym
->declared_at
))
12770 /* Resolve associate names. */
12772 resolve_assoc_var (sym
, true);
12774 /* Assign default type to symbols that need one and don't have one. */
12775 if (sym
->ts
.type
== BT_UNKNOWN
)
12777 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12779 gfc_set_default_type (sym
, 1, NULL
);
12782 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12783 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12784 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12785 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12787 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12789 /* The specific case of an external procedure should emit an error
12790 in the case that there is no implicit type. */
12792 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12795 /* Result may be in another namespace. */
12796 resolve_symbol (sym
->result
);
12798 if (!sym
->result
->attr
.proc_pointer
)
12800 sym
->ts
= sym
->result
->ts
;
12801 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12802 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12803 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12804 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12805 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12810 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12812 bool saved_specification_expr
= specification_expr
;
12813 specification_expr
= true;
12814 gfc_resolve_array_spec (sym
->result
->as
, false);
12815 specification_expr
= saved_specification_expr
;
12818 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12820 as
= CLASS_DATA (sym
)->as
;
12821 class_attr
= CLASS_DATA (sym
)->attr
;
12822 class_attr
.pointer
= class_attr
.class_pointer
;
12826 class_attr
= sym
->attr
;
12831 if (sym
->attr
.contiguous
12832 && (!class_attr
.dimension
12833 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12834 && !class_attr
.pointer
)))
12836 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12837 "array pointer or an assumed-shape or assumed-rank array",
12838 sym
->name
, &sym
->declared_at
);
12842 /* Assumed size arrays and assumed shape arrays must be dummy
12843 arguments. Array-spec's of implied-shape should have been resolved to
12844 AS_EXPLICIT already. */
12848 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12849 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12850 || as
->type
== AS_ASSUMED_SHAPE
)
12851 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
12853 if (as
->type
== AS_ASSUMED_SIZE
)
12854 gfc_error ("Assumed size array at %L must be a dummy argument",
12855 &sym
->declared_at
);
12857 gfc_error ("Assumed shape array at %L must be a dummy argument",
12858 &sym
->declared_at
);
12861 /* TS 29113, C535a. */
12862 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
12863 && !sym
->attr
.select_type_temporary
)
12865 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12866 &sym
->declared_at
);
12869 if (as
->type
== AS_ASSUMED_RANK
12870 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12872 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12873 "CODIMENSION attribute", &sym
->declared_at
);
12878 /* Make sure symbols with known intent or optional are really dummy
12879 variable. Because of ENTRY statement, this has to be deferred
12880 until resolution time. */
12882 if (!sym
->attr
.dummy
12883 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12885 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12889 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12891 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12892 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12896 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12898 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12899 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12901 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12902 "attribute must have constant length",
12903 sym
->name
, &sym
->declared_at
);
12907 if (sym
->ts
.is_c_interop
12908 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12910 gfc_error ("C interoperable character dummy variable '%s' at %L "
12911 "with VALUE attribute must have length one",
12912 sym
->name
, &sym
->declared_at
);
12917 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12918 && sym
->ts
.u
.derived
->attr
.generic
)
12920 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12921 if (!sym
->ts
.u
.derived
)
12923 gfc_error ("The derived type '%s' at %L is of type '%s', "
12924 "which has not been defined", sym
->name
,
12925 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12926 sym
->ts
.type
= BT_UNKNOWN
;
12931 /* Use the same constraints as TYPE(*), except for the type check
12932 and that only scalars and assumed-size arrays are permitted. */
12933 if (sym
->attr
.ext_attr
& (1 << EXT_ATTR_NO_ARG_CHECK
))
12935 if (!sym
->attr
.dummy
)
12937 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12938 "a dummy argument", sym
->name
, &sym
->declared_at
);
12942 if (sym
->ts
.type
!= BT_ASSUMED
&& sym
->ts
.type
!= BT_INTEGER
12943 && sym
->ts
.type
!= BT_REAL
&& sym
->ts
.type
!= BT_LOGICAL
12944 && sym
->ts
.type
!= BT_COMPLEX
)
12946 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be "
12947 "of type TYPE(*) or of an numeric intrinsic type",
12948 sym
->name
, &sym
->declared_at
);
12952 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12953 || sym
->attr
.pointer
|| sym
->attr
.value
)
12955 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12956 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE "
12957 "attribute", sym
->name
, &sym
->declared_at
);
12961 if (sym
->attr
.intent
== INTENT_OUT
)
12963 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not "
12964 "have the INTENT(OUT) attribute",
12965 sym
->name
, &sym
->declared_at
);
12968 if (sym
->attr
.dimension
&& sym
->as
->type
!= AS_ASSUMED_SIZE
)
12970 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall "
12971 "either be a scalar or an assumed-size array",
12972 sym
->name
, &sym
->declared_at
);
12976 /* Set the type to TYPE(*) and add a dimension(*) to ensure
12977 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with
12979 sym
->ts
.type
= BT_ASSUMED
;
12980 sym
->as
= gfc_get_array_spec ();
12981 sym
->as
->type
= AS_ASSUMED_SIZE
;
12983 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
12985 else if (sym
->ts
.type
== BT_ASSUMED
)
12987 /* TS 29113, C407a. */
12988 if (!sym
->attr
.dummy
)
12990 gfc_error ("Assumed type of variable %s at %L is only permitted "
12991 "for dummy variables", sym
->name
, &sym
->declared_at
);
12994 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12995 || sym
->attr
.pointer
|| sym
->attr
.value
)
12997 gfc_error ("Assumed-type variable %s at %L may not have the "
12998 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12999 sym
->name
, &sym
->declared_at
);
13002 if (sym
->attr
.intent
== INTENT_OUT
)
13004 gfc_error ("Assumed-type variable %s at %L may not have the "
13005 "INTENT(OUT) attribute",
13006 sym
->name
, &sym
->declared_at
);
13009 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13011 gfc_error ("Assumed-type variable %s at %L shall not be an "
13012 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13017 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13018 do this for something that was implicitly typed because that is handled
13019 in gfc_set_default_type. Handle dummy arguments and procedure
13020 definitions separately. Also, anything that is use associated is not
13021 handled here but instead is handled in the module it is declared in.
13022 Finally, derived type definitions are allowed to be BIND(C) since that
13023 only implies that they're interoperable, and they are checked fully for
13024 interoperability when a variable is declared of that type. */
13025 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13026 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13027 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13031 /* First, make sure the variable is declared at the
13032 module-level scope (J3/04-007, Section 15.3). */
13033 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13034 sym
->attr
.in_common
== 0)
13036 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13037 "is neither a COMMON block nor declared at the "
13038 "module level scope", sym
->name
, &(sym
->declared_at
));
13041 else if (sym
->common_head
!= NULL
)
13043 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13047 /* If type() declaration, we need to verify that the components
13048 of the given type are all C interoperable, etc. */
13049 if (sym
->ts
.type
== BT_DERIVED
&&
13050 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13052 /* Make sure the user marked the derived type as BIND(C). If
13053 not, call the verify routine. This could print an error
13054 for the derived type more than once if multiple variables
13055 of that type are declared. */
13056 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13057 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13061 /* Verify the variable itself as C interoperable if it
13062 is BIND(C). It is not possible for this to succeed if
13063 the verify_bind_c_derived_type failed, so don't have to handle
13064 any error returned by verify_bind_c_derived_type. */
13065 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13066 sym
->common_block
);
13071 /* clear the is_bind_c flag to prevent reporting errors more than
13072 once if something failed. */
13073 sym
->attr
.is_bind_c
= 0;
13078 /* If a derived type symbol has reached this point, without its
13079 type being declared, we have an error. Notice that most
13080 conditions that produce undefined derived types have already
13081 been dealt with. However, the likes of:
13082 implicit type(t) (t) ..... call foo (t) will get us here if
13083 the type is not declared in the scope of the implicit
13084 statement. Change the type to BT_UNKNOWN, both because it is so
13085 and to prevent an ICE. */
13086 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13087 && sym
->ts
.u
.derived
->components
== NULL
13088 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13090 gfc_error ("The derived type '%s' at %L is of type '%s', "
13091 "which has not been defined", sym
->name
,
13092 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13093 sym
->ts
.type
= BT_UNKNOWN
;
13097 /* Make sure that the derived type has been resolved and that the
13098 derived type is visible in the symbol's namespace, if it is a
13099 module function and is not PRIVATE. */
13100 if (sym
->ts
.type
== BT_DERIVED
13101 && sym
->ts
.u
.derived
->attr
.use_assoc
13102 && sym
->ns
->proc_name
13103 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13104 && !resolve_fl_derived (sym
->ts
.u
.derived
))
13107 /* Unless the derived-type declaration is use associated, Fortran 95
13108 does not allow public entries of private derived types.
13109 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13110 161 in 95-006r3. */
13111 if (sym
->ts
.type
== BT_DERIVED
13112 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13113 && !sym
->ts
.u
.derived
->attr
.use_assoc
13114 && gfc_check_symbol_access (sym
)
13115 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13116 && !gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L of PRIVATE "
13117 "derived type '%s'",
13118 (sym
->attr
.flavor
== FL_PARAMETER
)
13119 ? "parameter" : "variable",
13120 sym
->name
, &sym
->declared_at
,
13121 sym
->ts
.u
.derived
->name
))
13124 /* F2008, C1302. */
13125 if (sym
->ts
.type
== BT_DERIVED
13126 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13127 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13128 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13129 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13131 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13132 "type LOCK_TYPE must be a coarray", sym
->name
,
13133 &sym
->declared_at
);
13137 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13138 default initialization is defined (5.1.2.4.4). */
13139 if (sym
->ts
.type
== BT_DERIVED
13141 && sym
->attr
.intent
== INTENT_OUT
13143 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13145 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13147 if (c
->initializer
)
13149 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13150 "ASSUMED SIZE and so cannot have a default initializer",
13151 sym
->name
, &sym
->declared_at
);
13158 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13159 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13161 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13162 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13167 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13168 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13169 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13170 || class_attr
.codimension
)
13171 && (sym
->attr
.result
|| sym
->result
== sym
))
13173 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13174 "a coarray component", sym
->name
, &sym
->declared_at
);
13179 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13180 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13182 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13183 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13188 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13189 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13190 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13191 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13192 || class_attr
.allocatable
))
13194 gfc_error ("Variable '%s' at %L with coarray component shall be a "
13195 "nonpointer, nonallocatable scalar, which is not a coarray",
13196 sym
->name
, &sym
->declared_at
);
13200 /* F2008, C526. The function-result case was handled above. */
13201 if (class_attr
.codimension
13202 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13203 || sym
->attr
.select_type_temporary
13204 || sym
->ns
->save_all
13205 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13206 || sym
->ns
->proc_name
->attr
.is_main_program
13207 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13209 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13210 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13214 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13215 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13217 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13218 "deferred shape", sym
->name
, &sym
->declared_at
);
13221 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13222 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13224 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13225 "deferred shape", sym
->name
, &sym
->declared_at
);
13230 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13231 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13232 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13233 || (class_attr
.codimension
&& class_attr
.allocatable
))
13234 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13236 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13237 "allocatable coarray or have coarray components",
13238 sym
->name
, &sym
->declared_at
);
13242 if (class_attr
.codimension
&& sym
->attr
.dummy
13243 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13245 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13246 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13247 sym
->ns
->proc_name
->name
);
13251 if (sym
->ts
.type
== BT_LOGICAL
13252 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13253 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13254 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13257 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13258 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13260 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13261 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at "
13262 "%L with non-C_Bool kind in BIND(C) procedure "
13263 "'%s'", sym
->name
, &sym
->declared_at
,
13264 sym
->ns
->proc_name
->name
))
13266 else if (!gfc_logical_kinds
[i
].c_bool
13267 && !gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable "
13268 "'%s' at %L with non-C_Bool kind in "
13269 "BIND(C) procedure '%s'", sym
->name
,
13271 sym
->attr
.function
? sym
->name
13272 : sym
->ns
->proc_name
->name
))
13276 switch (sym
->attr
.flavor
)
13279 if (!resolve_fl_variable (sym
, mp_flag
))
13284 if (!resolve_fl_procedure (sym
, mp_flag
))
13289 if (!resolve_fl_namelist (sym
))
13294 if (!resolve_fl_parameter (sym
))
13302 /* Resolve array specifier. Check as well some constraints
13303 on COMMON blocks. */
13305 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13307 /* Set the formal_arg_flag so that check_conflict will not throw
13308 an error for host associated variables in the specification
13309 expression for an array_valued function. */
13310 if (sym
->attr
.function
&& sym
->as
)
13311 formal_arg_flag
= 1;
13313 saved_specification_expr
= specification_expr
;
13314 specification_expr
= true;
13315 gfc_resolve_array_spec (sym
->as
, check_constant
);
13316 specification_expr
= saved_specification_expr
;
13318 formal_arg_flag
= 0;
13320 /* Resolve formal namespaces. */
13321 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13322 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13323 gfc_resolve (sym
->formal_ns
);
13325 /* Make sure the formal namespace is present. */
13326 if (sym
->formal
&& !sym
->formal_ns
)
13328 gfc_formal_arglist
*formal
= sym
->formal
;
13329 while (formal
&& !formal
->sym
)
13330 formal
= formal
->next
;
13334 sym
->formal_ns
= formal
->sym
->ns
;
13335 if (sym
->ns
!= formal
->sym
->ns
)
13336 sym
->formal_ns
->refs
++;
13340 /* Check threadprivate restrictions. */
13341 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13342 && (!sym
->attr
.in_common
13343 && sym
->module
== NULL
13344 && (sym
->ns
->proc_name
== NULL
13345 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13346 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13348 /* If we have come this far we can apply default-initializers, as
13349 described in 14.7.5, to those variables that have not already
13350 been assigned one. */
13351 if (sym
->ts
.type
== BT_DERIVED
13353 && !sym
->attr
.allocatable
13354 && !sym
->attr
.alloc_comp
)
13356 symbol_attribute
*a
= &sym
->attr
;
13358 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13359 && !a
->in_common
&& !a
->use_assoc
13360 && (a
->referenced
|| a
->result
)
13361 && !(a
->function
&& sym
!= sym
->result
))
13362 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13363 apply_default_init (sym
);
13366 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13367 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13368 && !CLASS_DATA (sym
)->attr
.class_pointer
13369 && !CLASS_DATA (sym
)->attr
.allocatable
)
13370 apply_default_init (sym
);
13372 /* If this symbol has a type-spec, check it. */
13373 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13374 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13375 if (!resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
))
13380 /************* Resolve DATA statements *************/
13384 gfc_data_value
*vnode
;
13390 /* Advance the values structure to point to the next value in the data list. */
13393 next_data_value (void)
13395 while (mpz_cmp_ui (values
.left
, 0) == 0)
13398 if (values
.vnode
->next
== NULL
)
13401 values
.vnode
= values
.vnode
->next
;
13402 mpz_set (values
.left
, values
.vnode
->repeat
);
13410 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13416 ar_type mark
= AR_UNKNOWN
;
13418 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13424 if (!gfc_resolve_expr (var
->expr
))
13428 mpz_init_set_si (offset
, 0);
13431 if (e
->expr_type
!= EXPR_VARIABLE
)
13432 gfc_internal_error ("check_data_variable(): Bad expression");
13434 sym
= e
->symtree
->n
.sym
;
13436 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13438 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13439 sym
->name
, &sym
->declared_at
);
13442 if (e
->ref
== NULL
&& sym
->as
)
13444 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13445 " declaration", sym
->name
, where
);
13449 has_pointer
= sym
->attr
.pointer
;
13451 if (gfc_is_coindexed (e
))
13453 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13458 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13460 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13464 && ref
->type
== REF_ARRAY
13465 && ref
->u
.ar
.type
!= AR_FULL
)
13467 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13468 "be a full array", sym
->name
, where
);
13473 if (e
->rank
== 0 || has_pointer
)
13475 mpz_init_set_ui (size
, 1);
13482 /* Find the array section reference. */
13483 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13485 if (ref
->type
!= REF_ARRAY
)
13487 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13493 /* Set marks according to the reference pattern. */
13494 switch (ref
->u
.ar
.type
)
13502 /* Get the start position of array section. */
13503 gfc_get_section_index (ar
, section_index
, &offset
);
13508 gcc_unreachable ();
13511 if (!gfc_array_size (e
, &size
))
13513 gfc_error ("Nonconstant array section at %L in DATA statement",
13515 mpz_clear (offset
);
13522 while (mpz_cmp_ui (size
, 0) > 0)
13524 if (!next_data_value ())
13526 gfc_error ("DATA statement at %L has more variables than values",
13532 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13536 /* If we have more than one element left in the repeat count,
13537 and we have more than one element left in the target variable,
13538 then create a range assignment. */
13539 /* FIXME: Only done for full arrays for now, since array sections
13541 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13542 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13546 if (mpz_cmp (size
, values
.left
) >= 0)
13548 mpz_init_set (range
, values
.left
);
13549 mpz_sub (size
, size
, values
.left
);
13550 mpz_set_ui (values
.left
, 0);
13554 mpz_init_set (range
, size
);
13555 mpz_sub (values
.left
, values
.left
, size
);
13556 mpz_set_ui (size
, 0);
13559 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13562 mpz_add (offset
, offset
, range
);
13569 /* Assign initial value to symbol. */
13572 mpz_sub_ui (values
.left
, values
.left
, 1);
13573 mpz_sub_ui (size
, size
, 1);
13575 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13580 if (mark
== AR_FULL
)
13581 mpz_add_ui (offset
, offset
, 1);
13583 /* Modify the array section indexes and recalculate the offset
13584 for next element. */
13585 else if (mark
== AR_SECTION
)
13586 gfc_advance_section (section_index
, ar
, &offset
);
13590 if (mark
== AR_SECTION
)
13592 for (i
= 0; i
< ar
->dimen
; i
++)
13593 mpz_clear (section_index
[i
]);
13597 mpz_clear (offset
);
13603 static bool traverse_data_var (gfc_data_variable
*, locus
*);
13605 /* Iterate over a list of elements in a DATA statement. */
13608 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13611 iterator_stack frame
;
13612 gfc_expr
*e
, *start
, *end
, *step
;
13613 bool retval
= true;
13615 mpz_init (frame
.value
);
13618 start
= gfc_copy_expr (var
->iter
.start
);
13619 end
= gfc_copy_expr (var
->iter
.end
);
13620 step
= gfc_copy_expr (var
->iter
.step
);
13622 if (!gfc_simplify_expr (start
, 1)
13623 || start
->expr_type
!= EXPR_CONSTANT
)
13625 gfc_error ("start of implied-do loop at %L could not be "
13626 "simplified to a constant value", &start
->where
);
13630 if (!gfc_simplify_expr (end
, 1)
13631 || end
->expr_type
!= EXPR_CONSTANT
)
13633 gfc_error ("end of implied-do loop at %L could not be "
13634 "simplified to a constant value", &start
->where
);
13638 if (!gfc_simplify_expr (step
, 1)
13639 || step
->expr_type
!= EXPR_CONSTANT
)
13641 gfc_error ("step of implied-do loop at %L could not be "
13642 "simplified to a constant value", &start
->where
);
13647 mpz_set (trip
, end
->value
.integer
);
13648 mpz_sub (trip
, trip
, start
->value
.integer
);
13649 mpz_add (trip
, trip
, step
->value
.integer
);
13651 mpz_div (trip
, trip
, step
->value
.integer
);
13653 mpz_set (frame
.value
, start
->value
.integer
);
13655 frame
.prev
= iter_stack
;
13656 frame
.variable
= var
->iter
.var
->symtree
;
13657 iter_stack
= &frame
;
13659 while (mpz_cmp_ui (trip
, 0) > 0)
13661 if (!traverse_data_var (var
->list
, where
))
13667 e
= gfc_copy_expr (var
->expr
);
13668 if (!gfc_simplify_expr (e
, 1))
13675 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13677 mpz_sub_ui (trip
, trip
, 1);
13681 mpz_clear (frame
.value
);
13684 gfc_free_expr (start
);
13685 gfc_free_expr (end
);
13686 gfc_free_expr (step
);
13688 iter_stack
= frame
.prev
;
13693 /* Type resolve variables in the variable list of a DATA statement. */
13696 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13700 for (; var
; var
= var
->next
)
13702 if (var
->expr
== NULL
)
13703 t
= traverse_data_list (var
, where
);
13705 t
= check_data_variable (var
, where
);
13715 /* Resolve the expressions and iterators associated with a data statement.
13716 This is separate from the assignment checking because data lists should
13717 only be resolved once. */
13720 resolve_data_variables (gfc_data_variable
*d
)
13722 for (; d
; d
= d
->next
)
13724 if (d
->list
== NULL
)
13726 if (!gfc_resolve_expr (d
->expr
))
13731 if (!gfc_resolve_iterator (&d
->iter
, false, true))
13734 if (!resolve_data_variables (d
->list
))
13743 /* Resolve a single DATA statement. We implement this by storing a pointer to
13744 the value list into static variables, and then recursively traversing the
13745 variables list, expanding iterators and such. */
13748 resolve_data (gfc_data
*d
)
13751 if (!resolve_data_variables (d
->var
))
13754 values
.vnode
= d
->value
;
13755 if (d
->value
== NULL
)
13756 mpz_set_ui (values
.left
, 0);
13758 mpz_set (values
.left
, d
->value
->repeat
);
13760 if (!traverse_data_var (d
->var
, &d
->where
))
13763 /* At this point, we better not have any values left. */
13765 if (next_data_value ())
13766 gfc_error ("DATA statement at %L has more values than variables",
13771 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13772 accessed by host or use association, is a dummy argument to a pure function,
13773 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13774 is storage associated with any such variable, shall not be used in the
13775 following contexts: (clients of this function). */
13777 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13778 procedure. Returns zero if assignment is OK, nonzero if there is a
13781 gfc_impure_variable (gfc_symbol
*sym
)
13786 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13789 /* Check if the symbol's ns is inside the pure procedure. */
13790 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13794 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13798 proc
= sym
->ns
->proc_name
;
13799 if (sym
->attr
.dummy
13800 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13801 || proc
->attr
.function
))
13804 /* TODO: Sort out what can be storage associated, if anything, and include
13805 it here. In principle equivalences should be scanned but it does not
13806 seem to be possible to storage associate an impure variable this way. */
13811 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13812 current namespace is inside a pure procedure. */
13815 gfc_pure (gfc_symbol
*sym
)
13817 symbol_attribute attr
;
13822 /* Check if the current namespace or one of its parents
13823 belongs to a pure procedure. */
13824 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13826 sym
= ns
->proc_name
;
13830 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13838 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13842 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13843 checks if the current namespace is implicitly pure. Note that this
13844 function returns false for a PURE procedure. */
13847 gfc_implicit_pure (gfc_symbol
*sym
)
13853 /* Check if the current procedure is implicit_pure. Walk up
13854 the procedure list until we find a procedure. */
13855 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13857 sym
= ns
->proc_name
;
13861 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13866 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13867 && !sym
->attr
.pure
;
13871 /* Test whether the current procedure is elemental or not. */
13874 gfc_elemental (gfc_symbol
*sym
)
13876 symbol_attribute attr
;
13879 sym
= gfc_current_ns
->proc_name
;
13884 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13888 /* Warn about unused labels. */
13891 warn_unused_fortran_label (gfc_st_label
*label
)
13896 warn_unused_fortran_label (label
->left
);
13898 if (label
->defined
== ST_LABEL_UNKNOWN
)
13901 switch (label
->referenced
)
13903 case ST_LABEL_UNKNOWN
:
13904 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13908 case ST_LABEL_BAD_TARGET
:
13909 gfc_warning ("Label %d at %L defined but cannot be used",
13910 label
->value
, &label
->where
);
13917 warn_unused_fortran_label (label
->right
);
13921 /* Returns the sequence type of a symbol or sequence. */
13924 sequence_type (gfc_typespec ts
)
13933 if (ts
.u
.derived
->components
== NULL
)
13934 return SEQ_NONDEFAULT
;
13936 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13937 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13938 if (sequence_type (c
->ts
) != result
)
13944 if (ts
.kind
!= gfc_default_character_kind
)
13945 return SEQ_NONDEFAULT
;
13947 return SEQ_CHARACTER
;
13950 if (ts
.kind
!= gfc_default_integer_kind
)
13951 return SEQ_NONDEFAULT
;
13953 return SEQ_NUMERIC
;
13956 if (!(ts
.kind
== gfc_default_real_kind
13957 || ts
.kind
== gfc_default_double_kind
))
13958 return SEQ_NONDEFAULT
;
13960 return SEQ_NUMERIC
;
13963 if (ts
.kind
!= gfc_default_complex_kind
)
13964 return SEQ_NONDEFAULT
;
13966 return SEQ_NUMERIC
;
13969 if (ts
.kind
!= gfc_default_logical_kind
)
13970 return SEQ_NONDEFAULT
;
13972 return SEQ_NUMERIC
;
13975 return SEQ_NONDEFAULT
;
13980 /* Resolve derived type EQUIVALENCE object. */
13983 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13985 gfc_component
*c
= derived
->components
;
13990 /* Shall not be an object of nonsequence derived type. */
13991 if (!derived
->attr
.sequence
)
13993 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13994 "attribute to be an EQUIVALENCE object", sym
->name
,
13999 /* Shall not have allocatable components. */
14000 if (derived
->attr
.alloc_comp
)
14002 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14003 "components to be an EQUIVALENCE object",sym
->name
,
14008 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14010 gfc_error ("Derived type variable '%s' at %L with default "
14011 "initialization cannot be in EQUIVALENCE with a variable "
14012 "in COMMON", sym
->name
, &e
->where
);
14016 for (; c
; c
= c
->next
)
14018 if (c
->ts
.type
== BT_DERIVED
14019 && (!resolve_equivalence_derived(c
->ts
.u
.derived
, sym
, e
)))
14022 /* Shall not be an object of sequence derived type containing a pointer
14023 in the structure. */
14024 if (c
->attr
.pointer
)
14026 gfc_error ("Derived type variable '%s' at %L with pointer "
14027 "component(s) cannot be an EQUIVALENCE object",
14028 sym
->name
, &e
->where
);
14036 /* Resolve equivalence object.
14037 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14038 an allocatable array, an object of nonsequence derived type, an object of
14039 sequence derived type containing a pointer at any level of component
14040 selection, an automatic object, a function name, an entry name, a result
14041 name, a named constant, a structure component, or a subobject of any of
14042 the preceding objects. A substring shall not have length zero. A
14043 derived type shall not have components with default initialization nor
14044 shall two objects of an equivalence group be initialized.
14045 Either all or none of the objects shall have an protected attribute.
14046 The simple constraints are done in symbol.c(check_conflict) and the rest
14047 are implemented here. */
14050 resolve_equivalence (gfc_equiv
*eq
)
14053 gfc_symbol
*first_sym
;
14056 locus
*last_where
= NULL
;
14057 seq_type eq_type
, last_eq_type
;
14058 gfc_typespec
*last_ts
;
14059 int object
, cnt_protected
;
14062 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14064 first_sym
= eq
->expr
->symtree
->n
.sym
;
14068 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14072 e
->ts
= e
->symtree
->n
.sym
->ts
;
14073 /* match_varspec might not know yet if it is seeing
14074 array reference or substring reference, as it doesn't
14076 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14078 gfc_ref
*ref
= e
->ref
;
14079 sym
= e
->symtree
->n
.sym
;
14081 if (sym
->attr
.dimension
)
14083 ref
->u
.ar
.as
= sym
->as
;
14087 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14088 if (e
->ts
.type
== BT_CHARACTER
14090 && ref
->type
== REF_ARRAY
14091 && ref
->u
.ar
.dimen
== 1
14092 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14093 && ref
->u
.ar
.stride
[0] == NULL
)
14095 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14096 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14099 /* Optimize away the (:) reference. */
14100 if (start
== NULL
&& end
== NULL
)
14103 e
->ref
= ref
->next
;
14105 e
->ref
->next
= ref
->next
;
14110 ref
->type
= REF_SUBSTRING
;
14112 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14114 ref
->u
.ss
.start
= start
;
14115 if (end
== NULL
&& e
->ts
.u
.cl
)
14116 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14117 ref
->u
.ss
.end
= end
;
14118 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14125 /* Any further ref is an error. */
14128 gcc_assert (ref
->type
== REF_ARRAY
);
14129 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14135 if (!gfc_resolve_expr (e
))
14138 sym
= e
->symtree
->n
.sym
;
14140 if (sym
->attr
.is_protected
)
14142 if (cnt_protected
> 0 && cnt_protected
!= object
)
14144 gfc_error ("Either all or none of the objects in the "
14145 "EQUIVALENCE set at %L shall have the "
14146 "PROTECTED attribute",
14151 /* Shall not equivalence common block variables in a PURE procedure. */
14152 if (sym
->ns
->proc_name
14153 && sym
->ns
->proc_name
->attr
.pure
14154 && sym
->attr
.in_common
)
14156 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14157 "object in the pure procedure '%s'",
14158 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14162 /* Shall not be a named constant. */
14163 if (e
->expr_type
== EXPR_CONSTANT
)
14165 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14166 "object", sym
->name
, &e
->where
);
14170 if (e
->ts
.type
== BT_DERIVED
14171 && !resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
))
14174 /* Check that the types correspond correctly:
14176 A numeric sequence structure may be equivalenced to another sequence
14177 structure, an object of default integer type, default real type, double
14178 precision real type, default logical type such that components of the
14179 structure ultimately only become associated to objects of the same
14180 kind. A character sequence structure may be equivalenced to an object
14181 of default character kind or another character sequence structure.
14182 Other objects may be equivalenced only to objects of the same type and
14183 kind parameters. */
14185 /* Identical types are unconditionally OK. */
14186 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14187 goto identical_types
;
14189 last_eq_type
= sequence_type (*last_ts
);
14190 eq_type
= sequence_type (sym
->ts
);
14192 /* Since the pair of objects is not of the same type, mixed or
14193 non-default sequences can be rejected. */
14195 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14196 "statement at %L with different type objects";
14198 && last_eq_type
== SEQ_MIXED
14199 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14200 || (eq_type
== SEQ_MIXED
14201 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14204 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14205 "statement at %L with objects of different type";
14207 && last_eq_type
== SEQ_NONDEFAULT
14208 && !gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
))
14209 || (eq_type
== SEQ_NONDEFAULT
14210 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
)))
14213 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14214 "EQUIVALENCE statement at %L";
14215 if (last_eq_type
== SEQ_CHARACTER
14216 && eq_type
!= SEQ_CHARACTER
14217 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14220 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14221 "EQUIVALENCE statement at %L";
14222 if (last_eq_type
== SEQ_NUMERIC
14223 && eq_type
!= SEQ_NUMERIC
14224 && !gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
, &e
->where
))
14229 last_where
= &e
->where
;
14234 /* Shall not be an automatic array. */
14235 if (e
->ref
->type
== REF_ARRAY
14236 && !gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1))
14238 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14239 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14246 /* Shall not be a structure component. */
14247 if (r
->type
== REF_COMPONENT
)
14249 gfc_error ("Structure component '%s' at %L cannot be an "
14250 "EQUIVALENCE object",
14251 r
->u
.c
.component
->name
, &e
->where
);
14255 /* A substring shall not have length zero. */
14256 if (r
->type
== REF_SUBSTRING
)
14258 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14260 gfc_error ("Substring at %L has length zero",
14261 &r
->u
.ss
.start
->where
);
14271 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14274 resolve_fntype (gfc_namespace
*ns
)
14276 gfc_entry_list
*el
;
14279 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14282 /* If there are any entries, ns->proc_name is the entry master
14283 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14285 sym
= ns
->entries
->sym
;
14287 sym
= ns
->proc_name
;
14288 if (sym
->result
== sym
14289 && sym
->ts
.type
== BT_UNKNOWN
14290 && !gfc_set_default_type (sym
, 0, NULL
)
14291 && !sym
->attr
.untyped
)
14293 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14294 sym
->name
, &sym
->declared_at
);
14295 sym
->attr
.untyped
= 1;
14298 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14299 && !sym
->attr
.contained
14300 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14301 && gfc_check_symbol_access (sym
))
14303 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14304 "%L of PRIVATE type '%s'", sym
->name
,
14305 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14309 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14311 if (el
->sym
->result
== el
->sym
14312 && el
->sym
->ts
.type
== BT_UNKNOWN
14313 && !gfc_set_default_type (el
->sym
, 0, NULL
)
14314 && !el
->sym
->attr
.untyped
)
14316 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14317 el
->sym
->name
, &el
->sym
->declared_at
);
14318 el
->sym
->attr
.untyped
= 1;
14324 /* 12.3.2.1.1 Defined operators. */
14327 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14329 gfc_formal_arglist
*formal
;
14331 if (!sym
->attr
.function
)
14333 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14334 sym
->name
, &where
);
14338 if (sym
->ts
.type
== BT_CHARACTER
14339 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14340 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14341 && sym
->result
->ts
.u
.cl
->length
))
14343 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14344 "character length", sym
->name
, &where
);
14348 formal
= gfc_sym_get_dummy_args (sym
);
14349 if (!formal
|| !formal
->sym
)
14351 gfc_error ("User operator procedure '%s' at %L must have at least "
14352 "one argument", sym
->name
, &where
);
14356 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14358 gfc_error ("First argument of operator interface at %L must be "
14359 "INTENT(IN)", &where
);
14363 if (formal
->sym
->attr
.optional
)
14365 gfc_error ("First argument of operator interface at %L cannot be "
14366 "optional", &where
);
14370 formal
= formal
->next
;
14371 if (!formal
|| !formal
->sym
)
14374 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14376 gfc_error ("Second argument of operator interface at %L must be "
14377 "INTENT(IN)", &where
);
14381 if (formal
->sym
->attr
.optional
)
14383 gfc_error ("Second argument of operator interface at %L cannot be "
14384 "optional", &where
);
14390 gfc_error ("Operator interface at %L must have, at most, two "
14391 "arguments", &where
);
14399 gfc_resolve_uops (gfc_symtree
*symtree
)
14401 gfc_interface
*itr
;
14403 if (symtree
== NULL
)
14406 gfc_resolve_uops (symtree
->left
);
14407 gfc_resolve_uops (symtree
->right
);
14409 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14410 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14414 /* Examine all of the expressions associated with a program unit,
14415 assign types to all intermediate expressions, make sure that all
14416 assignments are to compatible types and figure out which names
14417 refer to which functions or subroutines. It doesn't check code
14418 block, which is handled by resolve_code. */
14421 resolve_types (gfc_namespace
*ns
)
14427 gfc_namespace
* old_ns
= gfc_current_ns
;
14429 /* Check that all IMPLICIT types are ok. */
14430 if (!ns
->seen_implicit_none
)
14433 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14434 if (ns
->set_flag
[letter
]
14435 && !resolve_typespec_used (&ns
->default_type
[letter
],
14436 &ns
->implicit_loc
[letter
], NULL
))
14440 gfc_current_ns
= ns
;
14442 resolve_entries (ns
);
14444 resolve_common_vars (ns
->blank_common
.head
, false);
14445 resolve_common_blocks (ns
->common_root
);
14447 resolve_contained_functions (ns
);
14449 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14450 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14451 resolve_formal_arglist (ns
->proc_name
);
14453 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14455 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14456 resolve_charlen (cl
);
14458 gfc_traverse_ns (ns
, resolve_symbol
);
14460 resolve_fntype (ns
);
14462 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14464 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14465 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14466 "also be PURE", n
->proc_name
->name
,
14467 &n
->proc_name
->declared_at
);
14473 gfc_do_concurrent_flag
= 0;
14474 gfc_check_interfaces (ns
);
14476 gfc_traverse_ns (ns
, resolve_values
);
14482 for (d
= ns
->data
; d
; d
= d
->next
)
14486 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14488 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14490 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14491 resolve_equivalence (eq
);
14493 /* Warn about unused labels. */
14494 if (warn_unused_label
)
14495 warn_unused_fortran_label (ns
->st_labels
);
14497 gfc_resolve_uops (ns
->uop_root
);
14499 gfc_current_ns
= old_ns
;
14503 /* Call resolve_code recursively. */
14506 resolve_codes (gfc_namespace
*ns
)
14509 bitmap_obstack old_obstack
;
14511 if (ns
->resolved
== 1)
14514 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14517 gfc_current_ns
= ns
;
14519 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14520 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14523 /* Set to an out of range value. */
14524 current_entry_id
= -1;
14526 old_obstack
= labels_obstack
;
14527 bitmap_obstack_initialize (&labels_obstack
);
14529 resolve_code (ns
->code
, ns
);
14531 bitmap_obstack_release (&labels_obstack
);
14532 labels_obstack
= old_obstack
;
14536 /* This function is called after a complete program unit has been compiled.
14537 Its purpose is to examine all of the expressions associated with a program
14538 unit, assign types to all intermediate expressions, make sure that all
14539 assignments are to compatible types and figure out which names refer to
14540 which functions or subroutines. */
14543 gfc_resolve (gfc_namespace
*ns
)
14545 gfc_namespace
*old_ns
;
14546 code_stack
*old_cs_base
;
14552 old_ns
= gfc_current_ns
;
14553 old_cs_base
= cs_base
;
14555 resolve_types (ns
);
14556 component_assignment_level
= 0;
14557 resolve_codes (ns
);
14559 gfc_current_ns
= old_ns
;
14560 cs_base
= old_cs_base
;
14563 gfc_run_passes (ns
);