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 static int 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
) == FAILURE
)
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
) == FAILURE
)
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
) == FAILURE
)
309 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
310 resolve_formal_arglist (sym
);
312 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
314 if (sym
->attr
.flavor
== FL_UNKNOWN
)
315 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
319 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
320 && (!sym
->attr
.function
|| sym
->result
== sym
))
321 gfc_set_default_type (sym
, 1, sym
->ns
);
324 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
325 ? CLASS_DATA (sym
)->as
: sym
->as
;
327 saved_specification_expr
= specification_expr
;
328 specification_expr
= true;
329 gfc_resolve_array_spec (as
, 0);
330 specification_expr
= saved_specification_expr
;
332 /* We can't tell if an array with dimension (:) is assumed or deferred
333 shape until we know if it has the pointer or allocatable attributes.
335 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
336 && ((sym
->ts
.type
!= BT_CLASS
337 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
338 || (sym
->ts
.type
== BT_CLASS
339 && !(CLASS_DATA (sym
)->attr
.class_pointer
340 || CLASS_DATA (sym
)->attr
.allocatable
)))
341 && sym
->attr
.flavor
!= FL_PROCEDURE
)
343 as
->type
= AS_ASSUMED_SHAPE
;
344 for (i
= 0; i
< as
->rank
; i
++)
345 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
348 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
349 || (as
&& as
->type
== AS_ASSUMED_RANK
)
350 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
351 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
352 && (CLASS_DATA (sym
)->attr
.class_pointer
353 || CLASS_DATA (sym
)->attr
.allocatable
354 || CLASS_DATA (sym
)->attr
.target
))
355 || sym
->attr
.optional
)
357 proc
->attr
.always_explicit
= 1;
359 proc
->result
->attr
.always_explicit
= 1;
362 /* If the flavor is unknown at this point, it has to be a variable.
363 A procedure specification would have already set the type. */
365 if (sym
->attr
.flavor
== FL_UNKNOWN
)
366 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
370 if (sym
->attr
.flavor
== FL_PROCEDURE
)
375 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
376 "also be PURE", sym
->name
, &sym
->declared_at
);
380 else if (!sym
->attr
.pointer
)
382 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
385 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
386 " of pure function '%s' at %L with VALUE "
387 "attribute but without INTENT(IN)",
388 sym
->name
, proc
->name
, &sym
->declared_at
);
390 gfc_error ("Argument '%s' of pure function '%s' at %L must "
391 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
395 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
398 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
399 " of pure subroutine '%s' at %L with VALUE "
400 "attribute but without INTENT", sym
->name
,
401 proc
->name
, &sym
->declared_at
);
403 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
404 "must have its INTENT specified or have the "
405 "VALUE attribute", sym
->name
, proc
->name
,
411 if (proc
->attr
.implicit_pure
)
413 if (sym
->attr
.flavor
== FL_PROCEDURE
)
416 proc
->attr
.implicit_pure
= 0;
418 else if (!sym
->attr
.pointer
)
420 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
422 proc
->attr
.implicit_pure
= 0;
424 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
426 proc
->attr
.implicit_pure
= 0;
430 if (gfc_elemental (proc
))
433 if (sym
->attr
.codimension
434 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
435 && CLASS_DATA (sym
)->attr
.codimension
))
437 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
438 "procedure", sym
->name
, &sym
->declared_at
);
442 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
443 && CLASS_DATA (sym
)->as
))
445 gfc_error ("Argument '%s' of elemental procedure at %L must "
446 "be scalar", sym
->name
, &sym
->declared_at
);
450 if (sym
->attr
.allocatable
451 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
452 && CLASS_DATA (sym
)->attr
.allocatable
))
454 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
455 "have the ALLOCATABLE attribute", sym
->name
,
460 if (sym
->attr
.pointer
461 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
462 && CLASS_DATA (sym
)->attr
.class_pointer
))
464 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
465 "have the POINTER attribute", sym
->name
,
470 if (sym
->attr
.flavor
== FL_PROCEDURE
)
472 gfc_error ("Dummy procedure '%s' not allowed in elemental "
473 "procedure '%s' at %L", sym
->name
, proc
->name
,
478 /* Fortran 2008 Corrigendum 1, C1290a. */
479 if (sym
->attr
.intent
== INTENT_UNKNOWN
&& !sym
->attr
.value
)
481 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
482 "have its INTENT specified or have the VALUE "
483 "attribute", sym
->name
, proc
->name
,
489 /* Each dummy shall be specified to be scalar. */
490 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
494 gfc_error ("Argument '%s' of statement function at %L must "
495 "be scalar", sym
->name
, &sym
->declared_at
);
499 if (sym
->ts
.type
== BT_CHARACTER
)
501 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
502 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
504 gfc_error ("Character-valued argument '%s' of statement "
505 "function at %L must have constant length",
506 sym
->name
, &sym
->declared_at
);
516 /* Work function called when searching for symbols that have argument lists
517 associated with them. */
520 find_arglists (gfc_symbol
*sym
)
522 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
523 || sym
->attr
.flavor
== FL_DERIVED
)
526 resolve_formal_arglist (sym
);
530 /* Given a namespace, resolve all formal argument lists within the namespace.
534 resolve_formal_arglists (gfc_namespace
*ns
)
539 gfc_traverse_ns (ns
, find_arglists
);
544 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
548 /* If this namespace is not a function or an entry master function,
550 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
551 || sym
->attr
.entry_master
)
554 /* Try to find out of what the return type is. */
555 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
557 t
= gfc_set_default_type (sym
->result
, 0, ns
);
559 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
561 if (sym
->result
== sym
)
562 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
563 sym
->name
, &sym
->declared_at
);
564 else if (!sym
->result
->attr
.proc_pointer
)
565 gfc_error ("Result '%s' of contained function '%s' at %L has "
566 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
567 &sym
->result
->declared_at
);
568 sym
->result
->attr
.untyped
= 1;
572 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
573 type, lists the only ways a character length value of * can be used:
574 dummy arguments of procedures, named constants, and function results
575 in external functions. Internal function results and results of module
576 procedures are not on this list, ergo, not permitted. */
578 if (sym
->result
->ts
.type
== BT_CHARACTER
)
580 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
581 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
583 /* See if this is a module-procedure and adapt error message
586 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
587 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
589 gfc_error ("Character-valued %s '%s' at %L must not be"
591 module_proc
? _("module procedure")
592 : _("internal function"),
593 sym
->name
, &sym
->declared_at
);
599 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
600 introduce duplicates. */
603 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
605 gfc_formal_arglist
*f
, *new_arglist
;
608 for (; new_args
!= NULL
; new_args
= new_args
->next
)
610 new_sym
= new_args
->sym
;
611 /* See if this arg is already in the formal argument list. */
612 for (f
= proc
->formal
; f
; f
= f
->next
)
614 if (new_sym
== f
->sym
)
621 /* Add a new argument. Argument order is not important. */
622 new_arglist
= gfc_get_formal_arglist ();
623 new_arglist
->sym
= new_sym
;
624 new_arglist
->next
= proc
->formal
;
625 proc
->formal
= new_arglist
;
630 /* Flag the arguments that are not present in all entries. */
633 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
635 gfc_formal_arglist
*f
, *head
;
638 for (f
= proc
->formal
; f
; f
= f
->next
)
643 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
645 if (new_args
->sym
== f
->sym
)
652 f
->sym
->attr
.not_always_present
= 1;
657 /* Resolve alternate entry points. If a symbol has multiple entry points we
658 create a new master symbol for the main routine, and turn the existing
659 symbol into an entry point. */
662 resolve_entries (gfc_namespace
*ns
)
664 gfc_namespace
*old_ns
;
668 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
669 static int master_count
= 0;
671 if (ns
->proc_name
== NULL
)
674 /* No need to do anything if this procedure doesn't have alternate entry
679 /* We may already have resolved alternate entry points. */
680 if (ns
->proc_name
->attr
.entry_master
)
683 /* If this isn't a procedure something has gone horribly wrong. */
684 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
686 /* Remember the current namespace. */
687 old_ns
= gfc_current_ns
;
691 /* Add the main entry point to the list of entry points. */
692 el
= gfc_get_entry_list ();
693 el
->sym
= ns
->proc_name
;
695 el
->next
= ns
->entries
;
697 ns
->proc_name
->attr
.entry
= 1;
699 /* If it is a module function, it needs to be in the right namespace
700 so that gfc_get_fake_result_decl can gather up the results. The
701 need for this arose in get_proc_name, where these beasts were
702 left in their own namespace, to keep prior references linked to
703 the entry declaration.*/
704 if (ns
->proc_name
->attr
.function
705 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
708 /* Do the same for entries where the master is not a module
709 procedure. These are retained in the module namespace because
710 of the module procedure declaration. */
711 for (el
= el
->next
; el
; el
= el
->next
)
712 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
713 && el
->sym
->attr
.mod_proc
)
717 /* Add an entry statement for it. */
724 /* Create a new symbol for the master function. */
725 /* Give the internal function a unique name (within this file).
726 Also include the function name so the user has some hope of figuring
727 out what is going on. */
728 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
729 master_count
++, ns
->proc_name
->name
);
730 gfc_get_ha_symbol (name
, &proc
);
731 gcc_assert (proc
!= NULL
);
733 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
734 if (ns
->proc_name
->attr
.subroutine
)
735 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
739 gfc_typespec
*ts
, *fts
;
740 gfc_array_spec
*as
, *fas
;
741 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
743 fas
= ns
->entries
->sym
->as
;
744 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
745 fts
= &ns
->entries
->sym
->result
->ts
;
746 if (fts
->type
== BT_UNKNOWN
)
747 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
748 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
750 ts
= &el
->sym
->result
->ts
;
752 as
= as
? as
: el
->sym
->result
->as
;
753 if (ts
->type
== BT_UNKNOWN
)
754 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
756 if (! gfc_compare_types (ts
, fts
)
757 || (el
->sym
->result
->attr
.dimension
758 != ns
->entries
->sym
->result
->attr
.dimension
)
759 || (el
->sym
->result
->attr
.pointer
760 != ns
->entries
->sym
->result
->attr
.pointer
))
762 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
763 && gfc_compare_array_spec (as
, fas
) == 0)
764 gfc_error ("Function %s at %L has entries with mismatched "
765 "array specifications", ns
->entries
->sym
->name
,
766 &ns
->entries
->sym
->declared_at
);
767 /* The characteristics need to match and thus both need to have
768 the same string length, i.e. both len=*, or both len=4.
769 Having both len=<variable> is also possible, but difficult to
770 check at compile time. */
771 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
772 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
773 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
775 && ts
->u
.cl
->length
->expr_type
776 != fts
->u
.cl
->length
->expr_type
)
778 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
779 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
780 fts
->u
.cl
->length
->value
.integer
) != 0)))
781 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
782 "entries returning variables of different "
783 "string lengths", ns
->entries
->sym
->name
,
784 &ns
->entries
->sym
->declared_at
);
789 sym
= ns
->entries
->sym
->result
;
790 /* All result types the same. */
792 if (sym
->attr
.dimension
)
793 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
794 if (sym
->attr
.pointer
)
795 gfc_add_pointer (&proc
->attr
, NULL
);
799 /* Otherwise the result will be passed through a union by
801 proc
->attr
.mixed_entry_master
= 1;
802 for (el
= ns
->entries
; el
; el
= el
->next
)
804 sym
= el
->sym
->result
;
805 if (sym
->attr
.dimension
)
807 if (el
== ns
->entries
)
808 gfc_error ("FUNCTION result %s can't be an array in "
809 "FUNCTION %s at %L", sym
->name
,
810 ns
->entries
->sym
->name
, &sym
->declared_at
);
812 gfc_error ("ENTRY result %s can't be an array in "
813 "FUNCTION %s at %L", sym
->name
,
814 ns
->entries
->sym
->name
, &sym
->declared_at
);
816 else if (sym
->attr
.pointer
)
818 if (el
== ns
->entries
)
819 gfc_error ("FUNCTION result %s can't be a POINTER in "
820 "FUNCTION %s at %L", sym
->name
,
821 ns
->entries
->sym
->name
, &sym
->declared_at
);
823 gfc_error ("ENTRY result %s can't be a POINTER in "
824 "FUNCTION %s at %L", sym
->name
,
825 ns
->entries
->sym
->name
, &sym
->declared_at
);
830 if (ts
->type
== BT_UNKNOWN
)
831 ts
= gfc_get_default_type (sym
->name
, NULL
);
835 if (ts
->kind
== gfc_default_integer_kind
)
839 if (ts
->kind
== gfc_default_real_kind
840 || ts
->kind
== gfc_default_double_kind
)
844 if (ts
->kind
== gfc_default_complex_kind
)
848 if (ts
->kind
== gfc_default_logical_kind
)
852 /* We will issue error elsewhere. */
860 if (el
== ns
->entries
)
861 gfc_error ("FUNCTION result %s can't be of type %s "
862 "in FUNCTION %s at %L", sym
->name
,
863 gfc_typename (ts
), ns
->entries
->sym
->name
,
866 gfc_error ("ENTRY result %s can't be of type %s "
867 "in FUNCTION %s at %L", sym
->name
,
868 gfc_typename (ts
), ns
->entries
->sym
->name
,
875 proc
->attr
.access
= ACCESS_PRIVATE
;
876 proc
->attr
.entry_master
= 1;
878 /* Merge all the entry point arguments. */
879 for (el
= ns
->entries
; el
; el
= el
->next
)
880 merge_argument_lists (proc
, el
->sym
->formal
);
882 /* Check the master formal arguments for any that are not
883 present in all entry points. */
884 for (el
= ns
->entries
; el
; el
= el
->next
)
885 check_argument_lists (proc
, el
->sym
->formal
);
887 /* Use the master function for the function body. */
888 ns
->proc_name
= proc
;
890 /* Finalize the new symbols. */
891 gfc_commit_symbols ();
893 /* Restore the original namespace. */
894 gfc_current_ns
= old_ns
;
898 /* Resolve common variables. */
900 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
902 gfc_symbol
*csym
= sym
;
904 for (; csym
; csym
= csym
->common_next
)
906 if (csym
->value
|| csym
->attr
.data
)
908 if (!csym
->ns
->is_block_data
)
909 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
910 "but only in BLOCK DATA initialization is "
911 "allowed", csym
->name
, &csym
->declared_at
);
912 else if (!named_common
)
913 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
914 "in a blank COMMON but initialization is only "
915 "allowed in named common blocks", csym
->name
,
919 if (UNLIMITED_POLY (csym
))
920 gfc_error_now ("'%s' in cannot appear in COMMON at %L "
921 "[F2008:C5100]", csym
->name
, &csym
->declared_at
);
923 if (csym
->ts
.type
!= BT_DERIVED
)
926 if (!(csym
->ts
.u
.derived
->attr
.sequence
927 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
928 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
929 "has neither the SEQUENCE nor the BIND(C) "
930 "attribute", csym
->name
, &csym
->declared_at
);
931 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
932 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
933 "has an ultimate component that is "
934 "allocatable", csym
->name
, &csym
->declared_at
);
935 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
936 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
937 "may not have default initializer", csym
->name
,
940 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
941 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
945 /* Resolve common blocks. */
947 resolve_common_blocks (gfc_symtree
*common_root
)
951 if (common_root
== NULL
)
954 if (common_root
->left
)
955 resolve_common_blocks (common_root
->left
);
956 if (common_root
->right
)
957 resolve_common_blocks (common_root
->right
);
959 resolve_common_vars (common_root
->n
.common
->head
, true);
961 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
965 if (sym
->attr
.flavor
== FL_PARAMETER
)
966 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
967 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
969 if (sym
->attr
.external
)
970 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
971 sym
->name
, &common_root
->n
.common
->where
);
973 if (sym
->attr
.intrinsic
)
974 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
975 sym
->name
, &common_root
->n
.common
->where
);
976 else if (sym
->attr
.result
977 || gfc_is_function_return_value (sym
, gfc_current_ns
))
978 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
979 "that is also a function result", sym
->name
,
980 &common_root
->n
.common
->where
);
981 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
982 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
983 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
984 "that is also a global procedure", sym
->name
,
985 &common_root
->n
.common
->where
);
989 /* Resolve contained function types. Because contained functions can call one
990 another, they have to be worked out before any of the contained procedures
993 The good news is that if a function doesn't already have a type, the only
994 way it can get one is through an IMPLICIT type or a RESULT variable, because
995 by definition contained functions are contained namespace they're contained
996 in, not in a sibling or parent namespace. */
999 resolve_contained_functions (gfc_namespace
*ns
)
1001 gfc_namespace
*child
;
1004 resolve_formal_arglists (ns
);
1006 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1008 /* Resolve alternate entry points first. */
1009 resolve_entries (child
);
1011 /* Then check function return types. */
1012 resolve_contained_fntype (child
->proc_name
, child
);
1013 for (el
= child
->entries
; el
; el
= el
->next
)
1014 resolve_contained_fntype (el
->sym
, child
);
1019 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
1022 /* Resolve all of the elements of a structure constructor and make sure that
1023 the types are correct. The 'init' flag indicates that the given
1024 constructor is an initializer. */
1027 resolve_structure_cons (gfc_expr
*expr
, int init
)
1029 gfc_constructor
*cons
;
1030 gfc_component
*comp
;
1036 if (expr
->ts
.type
== BT_DERIVED
)
1037 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1039 cons
= gfc_constructor_first (expr
->value
.constructor
);
1041 /* See if the user is trying to invoke a structure constructor for one of
1042 the iso_c_binding derived types. */
1043 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1044 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1045 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
1047 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
1048 expr
->ts
.u
.derived
->name
, &(expr
->where
));
1052 /* Return if structure constructor is c_null_(fun)prt. */
1053 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1054 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1055 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
1058 /* A constructor may have references if it is the result of substituting a
1059 parameter variable. In this case we just pull out the component we
1062 comp
= expr
->ref
->u
.c
.sym
->components
;
1064 comp
= expr
->ts
.u
.derived
->components
;
1066 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1073 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1079 rank
= comp
->as
? comp
->as
->rank
: 0;
1080 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1081 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1083 gfc_error ("The rank of the element in the structure "
1084 "constructor at %L does not match that of the "
1085 "component (%d/%d)", &cons
->expr
->where
,
1086 cons
->expr
->rank
, rank
);
1090 /* If we don't have the right type, try to convert it. */
1092 if (!comp
->attr
.proc_pointer
&&
1093 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1095 if (strcmp (comp
->name
, "_extends") == 0)
1097 /* Can afford to be brutal with the _extends initializer.
1098 The derived type can get lost because it is PRIVATE
1099 but it is not usage constrained by the standard. */
1100 cons
->expr
->ts
= comp
->ts
;
1102 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1104 gfc_error ("The element in the structure constructor at %L, "
1105 "for pointer component '%s', is %s but should be %s",
1106 &cons
->expr
->where
, comp
->name
,
1107 gfc_basic_typename (cons
->expr
->ts
.type
),
1108 gfc_basic_typename (comp
->ts
.type
));
1113 gfc_try t2
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1119 /* For strings, the length of the constructor should be the same as
1120 the one of the structure, ensure this if the lengths are known at
1121 compile time and when we are dealing with PARAMETER or structure
1123 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1124 && comp
->ts
.u
.cl
->length
1125 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1126 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1127 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1128 && cons
->expr
->rank
!= 0
1129 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1130 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1132 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1133 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1135 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1136 to make use of the gfc_resolve_character_array_constructor
1137 machinery. The expression is later simplified away to
1138 an array of string literals. */
1139 gfc_expr
*para
= cons
->expr
;
1140 cons
->expr
= gfc_get_expr ();
1141 cons
->expr
->ts
= para
->ts
;
1142 cons
->expr
->where
= para
->where
;
1143 cons
->expr
->expr_type
= EXPR_ARRAY
;
1144 cons
->expr
->rank
= para
->rank
;
1145 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1146 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1147 para
, &cons
->expr
->where
);
1149 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1152 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1153 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1155 gfc_charlen
*cl
, *cl2
;
1158 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1160 if (cl
== cons
->expr
->ts
.u
.cl
)
1168 cl2
->next
= cl
->next
;
1170 gfc_free_expr (cl
->length
);
1174 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1175 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1176 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1177 gfc_resolve_character_array_constructor (cons
->expr
);
1181 if (cons
->expr
->expr_type
== EXPR_NULL
1182 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1183 || comp
->attr
.proc_pointer
1184 || (comp
->ts
.type
== BT_CLASS
1185 && (CLASS_DATA (comp
)->attr
.class_pointer
1186 || CLASS_DATA (comp
)->attr
.allocatable
))))
1189 gfc_error ("The NULL in the structure constructor at %L is "
1190 "being applied to component '%s', which is neither "
1191 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1195 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1197 /* Check procedure pointer interface. */
1198 gfc_symbol
*s2
= NULL
;
1203 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1206 s2
= c2
->ts
.interface
;
1209 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1211 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1212 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1214 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1216 s2
= cons
->expr
->symtree
->n
.sym
;
1217 name
= cons
->expr
->symtree
->n
.sym
->name
;
1220 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1221 err
, sizeof (err
), NULL
, NULL
))
1223 gfc_error ("Interface mismatch for procedure-pointer component "
1224 "'%s' in structure constructor at %L: %s",
1225 comp
->name
, &cons
->expr
->where
, err
);
1230 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1231 || cons
->expr
->expr_type
== EXPR_NULL
)
1234 a
= gfc_expr_attr (cons
->expr
);
1236 if (!a
.pointer
&& !a
.target
)
1239 gfc_error ("The element in the structure constructor at %L, "
1240 "for pointer component '%s' should be a POINTER or "
1241 "a TARGET", &cons
->expr
->where
, comp
->name
);
1246 /* F08:C461. Additional checks for pointer initialization. */
1250 gfc_error ("Pointer initialization target at %L "
1251 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1256 gfc_error ("Pointer initialization target at %L "
1257 "must have the SAVE attribute", &cons
->expr
->where
);
1261 /* F2003, C1272 (3). */
1262 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1263 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1264 || gfc_is_coindexed (cons
->expr
)))
1267 gfc_error ("Invalid expression in the structure constructor for "
1268 "pointer component '%s' at %L in PURE procedure",
1269 comp
->name
, &cons
->expr
->where
);
1272 if (gfc_implicit_pure (NULL
)
1273 && cons
->expr
->expr_type
== EXPR_VARIABLE
1274 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1275 || gfc_is_coindexed (cons
->expr
)))
1276 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1284 /****************** Expression name resolution ******************/
1286 /* Returns 0 if a symbol was not declared with a type or
1287 attribute declaration statement, nonzero otherwise. */
1290 was_declared (gfc_symbol
*sym
)
1296 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1299 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1300 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1301 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1302 || a
.asynchronous
|| a
.codimension
)
1309 /* Determine if a symbol is generic or not. */
1312 generic_sym (gfc_symbol
*sym
)
1316 if (sym
->attr
.generic
||
1317 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1320 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1323 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1330 return generic_sym (s
);
1337 /* Determine if a symbol is specific or not. */
1340 specific_sym (gfc_symbol
*sym
)
1344 if (sym
->attr
.if_source
== IFSRC_IFBODY
1345 || sym
->attr
.proc
== PROC_MODULE
1346 || sym
->attr
.proc
== PROC_INTERNAL
1347 || sym
->attr
.proc
== PROC_ST_FUNCTION
1348 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1349 || sym
->attr
.external
)
1352 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1355 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1357 return (s
== NULL
) ? 0 : specific_sym (s
);
1361 /* Figure out if the procedure is specific, generic or unknown. */
1364 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1368 procedure_kind (gfc_symbol
*sym
)
1370 if (generic_sym (sym
))
1371 return PTYPE_GENERIC
;
1373 if (specific_sym (sym
))
1374 return PTYPE_SPECIFIC
;
1376 return PTYPE_UNKNOWN
;
1379 /* Check references to assumed size arrays. The flag need_full_assumed_size
1380 is nonzero when matching actual arguments. */
1382 static int need_full_assumed_size
= 0;
1385 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1387 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1390 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1391 What should it be? */
1392 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1393 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1394 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1396 gfc_error ("The upper bound in the last dimension must "
1397 "appear in the reference to the assumed size "
1398 "array '%s' at %L", sym
->name
, &e
->where
);
1405 /* Look for bad assumed size array references in argument expressions
1406 of elemental and array valued intrinsic procedures. Since this is
1407 called from procedure resolution functions, it only recurses at
1411 resolve_assumed_size_actual (gfc_expr
*e
)
1416 switch (e
->expr_type
)
1419 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1424 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1425 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1436 /* Check a generic procedure, passed as an actual argument, to see if
1437 there is a matching specific name. If none, it is an error, and if
1438 more than one, the reference is ambiguous. */
1440 count_specific_procs (gfc_expr
*e
)
1447 sym
= e
->symtree
->n
.sym
;
1449 for (p
= sym
->generic
; p
; p
= p
->next
)
1450 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1452 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1458 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1462 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1463 "argument at %L", sym
->name
, &e
->where
);
1469 /* See if a call to sym could possibly be a not allowed RECURSION because of
1470 a missing RECURSIVE declaration. This means that either sym is the current
1471 context itself, or sym is the parent of a contained procedure calling its
1472 non-RECURSIVE containing procedure.
1473 This also works if sym is an ENTRY. */
1476 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1478 gfc_symbol
* proc_sym
;
1479 gfc_symbol
* context_proc
;
1480 gfc_namespace
* real_context
;
1482 if (sym
->attr
.flavor
== FL_PROGRAM
1483 || sym
->attr
.flavor
== FL_DERIVED
)
1486 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1488 /* If we've got an ENTRY, find real procedure. */
1489 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1490 proc_sym
= sym
->ns
->entries
->sym
;
1494 /* If sym is RECURSIVE, all is well of course. */
1495 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1498 /* Find the context procedure's "real" symbol if it has entries.
1499 We look for a procedure symbol, so recurse on the parents if we don't
1500 find one (like in case of a BLOCK construct). */
1501 for (real_context
= context
; ; real_context
= real_context
->parent
)
1503 /* We should find something, eventually! */
1504 gcc_assert (real_context
);
1506 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1507 : real_context
->proc_name
);
1509 /* In some special cases, there may not be a proc_name, like for this
1511 real(bad_kind()) function foo () ...
1512 when checking the call to bad_kind ().
1513 In these cases, we simply return here and assume that the
1518 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1522 /* A call from sym's body to itself is recursion, of course. */
1523 if (context_proc
== proc_sym
)
1526 /* The same is true if context is a contained procedure and sym the
1528 if (context_proc
->attr
.contained
)
1530 gfc_symbol
* parent_proc
;
1532 gcc_assert (context
->parent
);
1533 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1534 : context
->parent
->proc_name
);
1536 if (parent_proc
== proc_sym
)
1544 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1545 its typespec and formal argument list. */
1548 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1550 gfc_intrinsic_sym
* isym
= NULL
;
1556 /* Already resolved. */
1557 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1560 /* We already know this one is an intrinsic, so we don't call
1561 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1562 gfc_find_subroutine directly to check whether it is a function or
1565 if (sym
->intmod_sym_id
)
1566 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1567 else if (!sym
->attr
.subroutine
)
1568 isym
= gfc_find_function (sym
->name
);
1572 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1573 && !sym
->attr
.implicit_type
)
1574 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1575 " ignored", sym
->name
, &sym
->declared_at
);
1577 if (!sym
->attr
.function
&&
1578 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1583 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1585 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1587 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1588 " specifier", sym
->name
, &sym
->declared_at
);
1592 if (!sym
->attr
.subroutine
&&
1593 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1598 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1603 gfc_copy_formal_args_intr (sym
, isym
);
1605 /* Check it is actually available in the standard settings. */
1606 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1609 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1610 " available in the current standard settings but %s. Use"
1611 " an appropriate -std=* option or enable -fall-intrinsics"
1612 " in order to use it.",
1613 sym
->name
, &sym
->declared_at
, symstd
);
1621 /* Resolve a procedure expression, like passing it to a called procedure or as
1622 RHS for a procedure pointer assignment. */
1625 resolve_procedure_expression (gfc_expr
* expr
)
1629 if (expr
->expr_type
!= EXPR_VARIABLE
)
1631 gcc_assert (expr
->symtree
);
1633 sym
= expr
->symtree
->n
.sym
;
1635 if (sym
->attr
.intrinsic
)
1636 gfc_resolve_intrinsic (sym
, &expr
->where
);
1638 if (sym
->attr
.flavor
!= FL_PROCEDURE
1639 || (sym
->attr
.function
&& sym
->result
== sym
))
1642 /* A non-RECURSIVE procedure that is used as procedure expression within its
1643 own body is in danger of being called recursively. */
1644 if (is_illegal_recursion (sym
, gfc_current_ns
))
1645 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1646 " itself recursively. Declare it RECURSIVE or use"
1647 " -frecursive", sym
->name
, &expr
->where
);
1653 /* Resolve an actual argument list. Most of the time, this is just
1654 resolving the expressions in the list.
1655 The exception is that we sometimes have to decide whether arguments
1656 that look like procedure arguments are really simple variable
1660 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1661 bool no_formal_args
)
1664 gfc_symtree
*parent_st
;
1666 int save_need_full_assumed_size
;
1667 gfc_try return_value
= FAILURE
;
1668 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1671 first_actual_arg
= true;
1673 for (; arg
; arg
= arg
->next
)
1678 /* Check the label is a valid branching target. */
1681 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1683 gfc_error ("Label %d referenced at %L is never defined",
1684 arg
->label
->value
, &arg
->label
->where
);
1688 first_actual_arg
= false;
1692 if (e
->expr_type
== EXPR_VARIABLE
1693 && e
->symtree
->n
.sym
->attr
.generic
1695 && count_specific_procs (e
) != 1)
1698 if (e
->ts
.type
!= BT_PROCEDURE
)
1700 save_need_full_assumed_size
= need_full_assumed_size
;
1701 if (e
->expr_type
!= EXPR_VARIABLE
)
1702 need_full_assumed_size
= 0;
1703 if (gfc_resolve_expr (e
) != SUCCESS
)
1705 need_full_assumed_size
= save_need_full_assumed_size
;
1709 /* See if the expression node should really be a variable reference. */
1711 sym
= e
->symtree
->n
.sym
;
1713 if (sym
->attr
.flavor
== FL_PROCEDURE
1714 || sym
->attr
.intrinsic
1715 || sym
->attr
.external
)
1719 /* If a procedure is not already determined to be something else
1720 check if it is intrinsic. */
1721 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1722 sym
->attr
.intrinsic
= 1;
1724 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1726 gfc_error ("Statement function '%s' at %L is not allowed as an "
1727 "actual argument", sym
->name
, &e
->where
);
1730 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1731 sym
->attr
.subroutine
);
1732 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1734 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1735 "actual argument", sym
->name
, &e
->where
);
1738 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1739 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1741 if (gfc_notify_std (GFC_STD_F2008
,
1742 "Internal procedure '%s' is"
1743 " used as actual argument at %L",
1744 sym
->name
, &e
->where
) == FAILURE
)
1748 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1750 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1751 "allowed as an actual argument at %L", sym
->name
,
1755 /* Check if a generic interface has a specific procedure
1756 with the same name before emitting an error. */
1757 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1760 /* Just in case a specific was found for the expression. */
1761 sym
= e
->symtree
->n
.sym
;
1763 /* If the symbol is the function that names the current (or
1764 parent) scope, then we really have a variable reference. */
1766 if (gfc_is_function_return_value (sym
, sym
->ns
))
1769 /* If all else fails, see if we have a specific intrinsic. */
1770 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1772 gfc_intrinsic_sym
*isym
;
1774 isym
= gfc_find_function (sym
->name
);
1775 if (isym
== NULL
|| !isym
->specific
)
1777 gfc_error ("Unable to find a specific INTRINSIC procedure "
1778 "for the reference '%s' at %L", sym
->name
,
1783 sym
->attr
.intrinsic
= 1;
1784 sym
->attr
.function
= 1;
1787 if (gfc_resolve_expr (e
) == FAILURE
)
1792 /* See if the name is a module procedure in a parent unit. */
1794 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1797 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1799 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1803 if (parent_st
== NULL
)
1806 sym
= parent_st
->n
.sym
;
1807 e
->symtree
= parent_st
; /* Point to the right thing. */
1809 if (sym
->attr
.flavor
== FL_PROCEDURE
1810 || sym
->attr
.intrinsic
1811 || sym
->attr
.external
)
1813 if (gfc_resolve_expr (e
) == FAILURE
)
1819 e
->expr_type
= EXPR_VARIABLE
;
1821 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1822 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1823 && CLASS_DATA (sym
)->as
))
1825 e
->rank
= sym
->ts
.type
== BT_CLASS
1826 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1827 e
->ref
= gfc_get_ref ();
1828 e
->ref
->type
= REF_ARRAY
;
1829 e
->ref
->u
.ar
.type
= AR_FULL
;
1830 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1831 ? CLASS_DATA (sym
)->as
: sym
->as
;
1834 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1835 primary.c (match_actual_arg). If above code determines that it
1836 is a variable instead, it needs to be resolved as it was not
1837 done at the beginning of this function. */
1838 save_need_full_assumed_size
= need_full_assumed_size
;
1839 if (e
->expr_type
!= EXPR_VARIABLE
)
1840 need_full_assumed_size
= 0;
1841 if (gfc_resolve_expr (e
) != SUCCESS
)
1843 need_full_assumed_size
= save_need_full_assumed_size
;
1846 /* Check argument list functions %VAL, %LOC and %REF. There is
1847 nothing to do for %REF. */
1848 if (arg
->name
&& arg
->name
[0] == '%')
1850 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1852 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1854 gfc_error ("By-value argument at %L is not of numeric "
1861 gfc_error ("By-value argument at %L cannot be an array or "
1862 "an array section", &e
->where
);
1866 /* Intrinsics are still PROC_UNKNOWN here. However,
1867 since same file external procedures are not resolvable
1868 in gfortran, it is a good deal easier to leave them to
1870 if (ptype
!= PROC_UNKNOWN
1871 && ptype
!= PROC_DUMMY
1872 && ptype
!= PROC_EXTERNAL
1873 && ptype
!= PROC_MODULE
)
1875 gfc_error ("By-value argument at %L is not allowed "
1876 "in this context", &e
->where
);
1881 /* Statement functions have already been excluded above. */
1882 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1883 && e
->ts
.type
== BT_PROCEDURE
)
1885 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1887 gfc_error ("Passing internal procedure at %L by location "
1888 "not allowed", &e
->where
);
1894 /* Fortran 2008, C1237. */
1895 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1896 && gfc_has_ultimate_pointer (e
))
1898 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1899 "component", &e
->where
);
1903 first_actual_arg
= false;
1906 return_value
= SUCCESS
;
1909 actual_arg
= actual_arg_sav
;
1910 first_actual_arg
= first_actual_arg_sav
;
1912 return return_value
;
1916 /* Do the checks of the actual argument list that are specific to elemental
1917 procedures. If called with c == NULL, we have a function, otherwise if
1918 expr == NULL, we have a subroutine. */
1921 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1923 gfc_actual_arglist
*arg0
;
1924 gfc_actual_arglist
*arg
;
1925 gfc_symbol
*esym
= NULL
;
1926 gfc_intrinsic_sym
*isym
= NULL
;
1928 gfc_intrinsic_arg
*iformal
= NULL
;
1929 gfc_formal_arglist
*eformal
= NULL
;
1930 bool formal_optional
= false;
1931 bool set_by_optional
= false;
1935 /* Is this an elemental procedure? */
1936 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1938 if (expr
->value
.function
.esym
!= NULL
1939 && expr
->value
.function
.esym
->attr
.elemental
)
1941 arg0
= expr
->value
.function
.actual
;
1942 esym
= expr
->value
.function
.esym
;
1944 else if (expr
->value
.function
.isym
!= NULL
1945 && expr
->value
.function
.isym
->elemental
)
1947 arg0
= expr
->value
.function
.actual
;
1948 isym
= expr
->value
.function
.isym
;
1953 else if (c
&& c
->ext
.actual
!= NULL
)
1955 arg0
= c
->ext
.actual
;
1957 if (c
->resolved_sym
)
1958 esym
= c
->resolved_sym
;
1960 esym
= c
->symtree
->n
.sym
;
1963 if (!esym
->attr
.elemental
)
1969 /* The rank of an elemental is the rank of its array argument(s). */
1970 for (arg
= arg0
; arg
; arg
= arg
->next
)
1972 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
1974 rank
= arg
->expr
->rank
;
1975 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1976 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1977 set_by_optional
= true;
1979 /* Function specific; set the result rank and shape. */
1983 if (!expr
->shape
&& arg
->expr
->shape
)
1985 expr
->shape
= gfc_get_shape (rank
);
1986 for (i
= 0; i
< rank
; i
++)
1987 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1994 /* If it is an array, it shall not be supplied as an actual argument
1995 to an elemental procedure unless an array of the same rank is supplied
1996 as an actual argument corresponding to a nonoptional dummy argument of
1997 that elemental procedure(12.4.1.5). */
1998 formal_optional
= false;
2000 iformal
= isym
->formal
;
2002 eformal
= esym
->formal
;
2004 for (arg
= arg0
; arg
; arg
= arg
->next
)
2008 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2009 formal_optional
= true;
2010 eformal
= eformal
->next
;
2012 else if (isym
&& iformal
)
2014 if (iformal
->optional
)
2015 formal_optional
= true;
2016 iformal
= iformal
->next
;
2019 formal_optional
= true;
2021 if (pedantic
&& arg
->expr
!= NULL
2022 && arg
->expr
->expr_type
== EXPR_VARIABLE
2023 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2026 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2027 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2029 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2030 "MISSING, it cannot be the actual argument of an "
2031 "ELEMENTAL procedure unless there is a non-optional "
2032 "argument with the same rank (12.4.1.5)",
2033 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2037 for (arg
= arg0
; arg
; arg
= arg
->next
)
2039 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2042 /* Being elemental, the last upper bound of an assumed size array
2043 argument must be present. */
2044 if (resolve_assumed_size_actual (arg
->expr
))
2047 /* Elemental procedure's array actual arguments must conform. */
2050 if (gfc_check_conformance (arg
->expr
, e
,
2051 "elemental procedure") == FAILURE
)
2058 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2059 is an array, the intent inout/out variable needs to be also an array. */
2060 if (rank
> 0 && esym
&& expr
== NULL
)
2061 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2062 arg
= arg
->next
, eformal
= eformal
->next
)
2063 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2064 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2065 && arg
->expr
&& arg
->expr
->rank
== 0)
2067 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2068 "ELEMENTAL subroutine '%s' is a scalar, but another "
2069 "actual argument is an array", &arg
->expr
->where
,
2070 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2071 : "INOUT", eformal
->sym
->name
, esym
->name
);
2078 /* This function does the checking of references to global procedures
2079 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2080 77 and 95 standards. It checks for a gsymbol for the name, making
2081 one if it does not already exist. If it already exists, then the
2082 reference being resolved must correspond to the type of gsymbol.
2083 Otherwise, the new symbol is equipped with the attributes of the
2084 reference. The corresponding code that is called in creating
2085 global entities is parse.c.
2087 In addition, for all but -std=legacy, the gsymbols are used to
2088 check the interfaces of external procedures from the same file.
2089 The namespace of the gsymbol is resolved and then, once this is
2090 done the interface is checked. */
2094 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2096 if (!gsym_ns
->proc_name
->attr
.recursive
)
2099 if (sym
->ns
== gsym_ns
)
2102 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2109 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2111 if (gsym_ns
->entries
)
2113 gfc_entry_list
*entry
= gsym_ns
->entries
;
2115 for (; entry
; entry
= entry
->next
)
2117 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2119 if (strcmp (gsym_ns
->proc_name
->name
,
2120 sym
->ns
->proc_name
->name
) == 0)
2124 && strcmp (gsym_ns
->proc_name
->name
,
2125 sym
->ns
->parent
->proc_name
->name
) == 0)
2134 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2135 gfc_actual_arglist
**actual
, int sub
)
2139 enum gfc_symbol_type type
;
2141 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2143 gsym
= gfc_get_gsymbol (sym
->name
);
2145 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2146 gfc_global_used (gsym
, where
);
2148 if (gfc_option
.flag_whole_file
2149 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2150 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2151 && gsym
->type
!= GSYM_UNKNOWN
2153 && gsym
->ns
->resolved
!= -1
2154 && gsym
->ns
->proc_name
2155 && not_in_recursive (sym
, gsym
->ns
)
2156 && not_entry_self_reference (sym
, gsym
->ns
))
2158 gfc_symbol
*def_sym
;
2160 /* Resolve the gsymbol namespace if needed. */
2161 if (!gsym
->ns
->resolved
)
2163 gfc_dt_list
*old_dt_list
;
2164 struct gfc_omp_saved_state old_omp_state
;
2166 /* Stash away derived types so that the backend_decls do not
2168 old_dt_list
= gfc_derived_types
;
2169 gfc_derived_types
= NULL
;
2170 /* And stash away openmp state. */
2171 gfc_omp_save_and_clear_state (&old_omp_state
);
2173 gfc_resolve (gsym
->ns
);
2175 /* Store the new derived types with the global namespace. */
2176 if (gfc_derived_types
)
2177 gsym
->ns
->derived_types
= gfc_derived_types
;
2179 /* Restore the derived types of this namespace. */
2180 gfc_derived_types
= old_dt_list
;
2181 /* And openmp state. */
2182 gfc_omp_restore_state (&old_omp_state
);
2185 /* Make sure that translation for the gsymbol occurs before
2186 the procedure currently being resolved. */
2187 ns
= gfc_global_ns_list
;
2188 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2190 if (ns
->sibling
== gsym
->ns
)
2192 ns
->sibling
= gsym
->ns
->sibling
;
2193 gsym
->ns
->sibling
= gfc_global_ns_list
;
2194 gfc_global_ns_list
= gsym
->ns
;
2199 def_sym
= gsym
->ns
->proc_name
;
2200 if (def_sym
->attr
.entry_master
)
2202 gfc_entry_list
*entry
;
2203 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2204 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2206 def_sym
= entry
->sym
;
2211 /* Differences in constant character lengths. */
2212 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2214 long int l1
= 0, l2
= 0;
2215 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2216 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2219 && cl1
->length
!= NULL
2220 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2221 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2224 && cl2
->length
!= NULL
2225 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2226 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2228 if (l1
&& l2
&& l1
!= l2
)
2229 gfc_error ("Character length mismatch in return type of "
2230 "function '%s' at %L (%ld/%ld)", sym
->name
,
2231 &sym
->declared_at
, l1
, l2
);
2234 /* Type mismatch of function return type and expected type. */
2235 if (sym
->attr
.function
2236 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2237 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2238 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2239 gfc_typename (&def_sym
->ts
));
2241 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2243 gfc_formal_arglist
*arg
= def_sym
->formal
;
2244 for ( ; arg
; arg
= arg
->next
)
2247 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2248 else if (arg
->sym
->attr
.allocatable
2249 || arg
->sym
->attr
.asynchronous
2250 || arg
->sym
->attr
.optional
2251 || arg
->sym
->attr
.pointer
2252 || arg
->sym
->attr
.target
2253 || arg
->sym
->attr
.value
2254 || arg
->sym
->attr
.volatile_
)
2256 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2257 "has an attribute that requires an explicit "
2258 "interface for this procedure", arg
->sym
->name
,
2259 sym
->name
, &sym
->declared_at
);
2262 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2263 else if (arg
->sym
&& arg
->sym
->as
2264 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2266 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2267 "argument '%s' must have an explicit interface",
2268 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2271 /* TS 29113, 6.2. */
2272 else if (arg
->sym
&& arg
->sym
->as
2273 && arg
->sym
->as
->type
== AS_ASSUMED_RANK
)
2275 gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
2276 "argument '%s' must have an explicit interface",
2277 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2280 /* F2008, 12.4.2.2 (2c) */
2281 else if (arg
->sym
->attr
.codimension
)
2283 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2284 "'%s' must have an explicit interface",
2285 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2288 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2289 else if (false) /* TODO: is a parametrized derived type */
2291 gfc_error ("Procedure '%s' at %L with parametrized derived "
2292 "type argument '%s' must have an explicit "
2293 "interface", sym
->name
, &sym
->declared_at
,
2297 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2298 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2300 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2301 "argument '%s' must have an explicit interface",
2302 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2305 /* As assumed-type is unlimited polymorphic (cf. above).
2306 See also TS 29113, Note 6.1. */
2307 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2309 gfc_error ("Procedure '%s' at %L with assumed-type dummy "
2310 "argument '%s' must have an explicit interface",
2311 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2316 if (def_sym
->attr
.function
)
2318 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2319 if (def_sym
->as
&& def_sym
->as
->rank
2320 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2321 gfc_error ("The reference to function '%s' at %L either needs an "
2322 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2325 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2326 if ((def_sym
->result
->attr
.pointer
2327 || def_sym
->result
->attr
.allocatable
)
2328 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2329 || def_sym
->result
->attr
.pointer
2330 != sym
->result
->attr
.pointer
2331 || def_sym
->result
->attr
.allocatable
2332 != sym
->result
->attr
.allocatable
))
2333 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2334 "result must have an explicit interface", sym
->name
,
2337 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2338 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2339 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2341 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2343 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2344 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2346 gfc_error ("Nonconstant character-length function '%s' at %L "
2347 "must have an explicit interface", sym
->name
,
2353 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2354 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2356 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2357 "interface", sym
->name
, &sym
->declared_at
);
2360 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2361 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2363 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2364 "an explicit interface", sym
->name
, &sym
->declared_at
);
2367 if (gfc_option
.flag_whole_file
== 1
2368 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2369 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2370 gfc_errors_to_warnings (1);
2372 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2373 gfc_procedure_use (def_sym
, actual
, where
);
2375 gfc_errors_to_warnings (0);
2378 if (gsym
->type
== GSYM_UNKNOWN
)
2381 gsym
->where
= *where
;
2388 /************* Function resolution *************/
2390 /* Resolve a function call known to be generic.
2391 Section 14.1.2.4.1. */
2394 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2398 if (sym
->attr
.generic
)
2400 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2403 expr
->value
.function
.name
= s
->name
;
2404 expr
->value
.function
.esym
= s
;
2406 if (s
->ts
.type
!= BT_UNKNOWN
)
2408 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2409 expr
->ts
= s
->result
->ts
;
2412 expr
->rank
= s
->as
->rank
;
2413 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2414 expr
->rank
= s
->result
->as
->rank
;
2416 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2421 /* TODO: Need to search for elemental references in generic
2425 if (sym
->attr
.intrinsic
)
2426 return gfc_intrinsic_func_interface (expr
, 0);
2433 resolve_generic_f (gfc_expr
*expr
)
2437 gfc_interface
*intr
= NULL
;
2439 sym
= expr
->symtree
->n
.sym
;
2443 m
= resolve_generic_f0 (expr
, sym
);
2446 else if (m
== MATCH_ERROR
)
2451 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2452 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2455 if (sym
->ns
->parent
== NULL
)
2457 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2461 if (!generic_sym (sym
))
2465 /* Last ditch attempt. See if the reference is to an intrinsic
2466 that possesses a matching interface. 14.1.2.4 */
2467 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2469 gfc_error ("There is no specific function for the generic '%s' "
2470 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2476 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2479 return resolve_structure_cons (expr
, 0);
2482 m
= gfc_intrinsic_func_interface (expr
, 0);
2487 gfc_error ("Generic function '%s' at %L is not consistent with a "
2488 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2495 /* Resolve a function call known to be specific. */
2498 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2502 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2504 if (sym
->attr
.dummy
)
2506 sym
->attr
.proc
= PROC_DUMMY
;
2510 sym
->attr
.proc
= PROC_EXTERNAL
;
2514 if (sym
->attr
.proc
== PROC_MODULE
2515 || sym
->attr
.proc
== PROC_ST_FUNCTION
2516 || sym
->attr
.proc
== PROC_INTERNAL
)
2519 if (sym
->attr
.intrinsic
)
2521 m
= gfc_intrinsic_func_interface (expr
, 1);
2525 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2526 "with an intrinsic", sym
->name
, &expr
->where
);
2534 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2537 expr
->ts
= sym
->result
->ts
;
2540 expr
->value
.function
.name
= sym
->name
;
2541 expr
->value
.function
.esym
= sym
;
2542 if (sym
->as
!= NULL
)
2543 expr
->rank
= sym
->as
->rank
;
2550 resolve_specific_f (gfc_expr
*expr
)
2555 sym
= expr
->symtree
->n
.sym
;
2559 m
= resolve_specific_f0 (sym
, expr
);
2562 if (m
== MATCH_ERROR
)
2565 if (sym
->ns
->parent
== NULL
)
2568 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2574 gfc_error ("Unable to resolve the specific function '%s' at %L",
2575 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2581 /* Resolve a procedure call not known to be generic nor specific. */
2584 resolve_unknown_f (gfc_expr
*expr
)
2589 sym
= expr
->symtree
->n
.sym
;
2591 if (sym
->attr
.dummy
)
2593 sym
->attr
.proc
= PROC_DUMMY
;
2594 expr
->value
.function
.name
= sym
->name
;
2598 /* See if we have an intrinsic function reference. */
2600 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2602 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2607 /* The reference is to an external name. */
2609 sym
->attr
.proc
= PROC_EXTERNAL
;
2610 expr
->value
.function
.name
= sym
->name
;
2611 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2613 if (sym
->as
!= NULL
)
2614 expr
->rank
= sym
->as
->rank
;
2616 /* Type of the expression is either the type of the symbol or the
2617 default type of the symbol. */
2620 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2622 if (sym
->ts
.type
!= BT_UNKNOWN
)
2626 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2628 if (ts
->type
== BT_UNKNOWN
)
2630 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2631 sym
->name
, &expr
->where
);
2642 /* Return true, if the symbol is an external procedure. */
2644 is_external_proc (gfc_symbol
*sym
)
2646 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2647 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2648 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2649 && !sym
->attr
.proc_pointer
2650 && !sym
->attr
.use_assoc
2658 /* Figure out if a function reference is pure or not. Also set the name
2659 of the function for a potential error message. Return nonzero if the
2660 function is PURE, zero if not. */
2662 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2665 pure_function (gfc_expr
*e
, const char **name
)
2671 if (e
->symtree
!= NULL
2672 && e
->symtree
->n
.sym
!= NULL
2673 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2674 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2676 if (e
->value
.function
.esym
)
2678 pure
= gfc_pure (e
->value
.function
.esym
);
2679 *name
= e
->value
.function
.esym
->name
;
2681 else if (e
->value
.function
.isym
)
2683 pure
= e
->value
.function
.isym
->pure
2684 || e
->value
.function
.isym
->elemental
;
2685 *name
= e
->value
.function
.isym
->name
;
2689 /* Implicit functions are not pure. */
2691 *name
= e
->value
.function
.name
;
2699 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2700 int *f ATTRIBUTE_UNUSED
)
2704 /* Don't bother recursing into other statement functions
2705 since they will be checked individually for purity. */
2706 if (e
->expr_type
!= EXPR_FUNCTION
2708 || e
->symtree
->n
.sym
== sym
2709 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2712 return pure_function (e
, &name
) ? false : true;
2717 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2719 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2724 is_scalar_expr_ptr (gfc_expr
*expr
)
2726 gfc_try retval
= SUCCESS
;
2731 /* See if we have a gfc_ref, which means we have a substring, array
2732 reference, or a component. */
2733 if (expr
->ref
!= NULL
)
2736 while (ref
->next
!= NULL
)
2742 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2743 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2748 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2750 else if (ref
->u
.ar
.type
== AR_FULL
)
2752 /* The user can give a full array if the array is of size 1. */
2753 if (ref
->u
.ar
.as
!= NULL
2754 && ref
->u
.ar
.as
->rank
== 1
2755 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2756 && ref
->u
.ar
.as
->lower
[0] != NULL
2757 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2758 && ref
->u
.ar
.as
->upper
[0] != NULL
2759 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2761 /* If we have a character string, we need to check if
2762 its length is one. */
2763 if (expr
->ts
.type
== BT_CHARACTER
)
2765 if (expr
->ts
.u
.cl
== NULL
2766 || expr
->ts
.u
.cl
->length
== NULL
2767 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2773 /* We have constant lower and upper bounds. If the
2774 difference between is 1, it can be considered a
2776 FIXME: Use gfc_dep_compare_expr instead. */
2777 start
= (int) mpz_get_si
2778 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2779 end
= (int) mpz_get_si
2780 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2781 if (end
- start
+ 1 != 1)
2796 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2798 /* Character string. Make sure it's of length 1. */
2799 if (expr
->ts
.u
.cl
== NULL
2800 || expr
->ts
.u
.cl
->length
== NULL
2801 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2804 else if (expr
->rank
!= 0)
2811 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2812 and, in the case of c_associated, set the binding label based on
2816 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2817 gfc_symbol
**new_sym
)
2819 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2820 int optional_arg
= 0;
2821 gfc_try retval
= SUCCESS
;
2822 gfc_symbol
*args_sym
;
2823 gfc_typespec
*arg_ts
;
2824 symbol_attribute arg_attr
;
2826 if (args
->expr
->expr_type
== EXPR_CONSTANT
2827 || args
->expr
->expr_type
== EXPR_OP
2828 || args
->expr
->expr_type
== EXPR_NULL
)
2830 gfc_error ("Argument to '%s' at %L is not a variable",
2831 sym
->name
, &(args
->expr
->where
));
2835 args_sym
= args
->expr
->symtree
->n
.sym
;
2837 /* The typespec for the actual arg should be that stored in the expr
2838 and not necessarily that of the expr symbol (args_sym), because
2839 the actual expression could be a part-ref of the expr symbol. */
2840 arg_ts
= &(args
->expr
->ts
);
2841 arg_attr
= gfc_expr_attr (args
->expr
);
2843 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2845 /* If the user gave two args then they are providing something for
2846 the optional arg (the second cptr). Therefore, set the name and
2847 binding label to the c_associated for two cptrs. Otherwise,
2848 set c_associated to expect one cptr. */
2852 sprintf (name
, "%s_2", sym
->name
);
2858 sprintf (name
, "%s_1", sym
->name
);
2862 /* Get a new symbol for the version of c_associated that
2864 *new_sym
= get_iso_c_sym (sym
, name
, NULL
, optional_arg
);
2866 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2867 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2869 sprintf (name
, "%s", sym
->name
);
2871 /* Error check the call. */
2872 if (args
->next
!= NULL
)
2874 gfc_error_now ("More actual than formal arguments in '%s' "
2875 "call at %L", name
, &(args
->expr
->where
));
2878 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2883 /* Make sure we have either the target or pointer attribute. */
2884 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2886 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2887 "a TARGET or an associated pointer",
2889 sym
->name
, &(args
->expr
->where
));
2893 if (gfc_is_coindexed (args
->expr
))
2895 gfc_error_now ("Coindexed argument not permitted"
2896 " in '%s' call at %L", name
,
2897 &(args
->expr
->where
));
2901 /* Follow references to make sure there are no array
2903 seen_section
= false;
2905 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2907 if (ref
->type
== REF_ARRAY
)
2909 if (ref
->u
.ar
.type
== AR_SECTION
)
2910 seen_section
= true;
2912 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2915 for (r
= ref
->next
; r
; r
=r
->next
)
2916 if (r
->type
== REF_COMPONENT
)
2918 gfc_error_now ("Array section not permitted"
2919 " in '%s' call at %L", name
,
2920 &(args
->expr
->where
));
2928 if (seen_section
&& retval
== SUCCESS
)
2929 gfc_warning ("Array section in '%s' call at %L", name
,
2930 &(args
->expr
->where
));
2932 /* See if we have interoperable type and type param. */
2933 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2934 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2936 if (args_sym
->attr
.target
== 1)
2938 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2939 has the target attribute and is interoperable. */
2940 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2941 allocatable variable that has the TARGET attribute and
2942 is not an array of zero size. */
2943 if (args_sym
->attr
.allocatable
== 1)
2945 if (args_sym
->attr
.dimension
!= 0
2946 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2948 gfc_error_now ("Allocatable variable '%s' used as a "
2949 "parameter to '%s' at %L must not be "
2950 "an array of zero size",
2951 args_sym
->name
, sym
->name
,
2952 &(args
->expr
->where
));
2958 /* A non-allocatable target variable with C
2959 interoperable type and type parameters must be
2961 if (args_sym
&& args_sym
->attr
.dimension
)
2963 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2965 gfc_error ("Assumed-shape array '%s' at %L "
2966 "cannot be an argument to the "
2967 "procedure '%s' because "
2968 "it is not C interoperable",
2970 &(args
->expr
->where
), sym
->name
);
2973 else if (args_sym
->as
->type
== AS_DEFERRED
)
2975 gfc_error ("Deferred-shape array '%s' at %L "
2976 "cannot be an argument to the "
2977 "procedure '%s' because "
2978 "it is not C interoperable",
2980 &(args
->expr
->where
), sym
->name
);
2985 /* Make sure it's not a character string. Arrays of
2986 any type should be ok if the variable is of a C
2987 interoperable type. */
2988 if (arg_ts
->type
== BT_CHARACTER
)
2989 if (arg_ts
->u
.cl
!= NULL
2990 && (arg_ts
->u
.cl
->length
== NULL
2991 || arg_ts
->u
.cl
->length
->expr_type
2994 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2996 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2998 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2999 "at %L must have a length of 1",
3000 args_sym
->name
, sym
->name
,
3001 &(args
->expr
->where
));
3006 else if (arg_attr
.pointer
3007 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3009 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
3011 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
3012 "associated scalar POINTER", args_sym
->name
,
3013 sym
->name
, &(args
->expr
->where
));
3019 /* The parameter is not required to be C interoperable. If it
3020 is not C interoperable, it must be a nonpolymorphic scalar
3021 with no length type parameters. It still must have either
3022 the pointer or target attribute, and it can be
3023 allocatable (but must be allocated when c_loc is called). */
3024 if (args
->expr
->rank
!= 0
3025 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3027 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
3028 "scalar", args_sym
->name
, sym
->name
,
3029 &(args
->expr
->where
));
3032 else if (arg_ts
->type
== BT_CHARACTER
3033 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3035 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
3036 "%L must have a length of 1",
3037 args_sym
->name
, sym
->name
,
3038 &(args
->expr
->where
));
3041 else if (arg_ts
->type
== BT_CLASS
)
3043 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
3044 "polymorphic", args_sym
->name
, sym
->name
,
3045 &(args
->expr
->where
));
3050 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
3052 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
3054 /* TODO: Update this error message to allow for procedure
3055 pointers once they are implemented. */
3056 gfc_error_now ("Argument '%s' to '%s' at %L must be a "
3058 args_sym
->name
, sym
->name
,
3059 &(args
->expr
->where
));
3062 else if (args_sym
->attr
.is_bind_c
!= 1
3063 && gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable "
3064 "argument '%s' to '%s' at %L",
3065 args_sym
->name
, sym
->name
,
3066 &(args
->expr
->where
)) == FAILURE
)
3070 /* for c_loc/c_funloc, the new symbol is the same as the old one */
3075 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
3076 "iso_c_binding function: '%s'!\n", sym
->name
);
3083 /* Resolve a function call, which means resolving the arguments, then figuring
3084 out which entity the name refers to. */
3087 resolve_function (gfc_expr
*expr
)
3089 gfc_actual_arglist
*arg
;
3094 procedure_type p
= PROC_INTRINSIC
;
3095 bool no_formal_args
;
3099 sym
= expr
->symtree
->n
.sym
;
3101 /* If this is a procedure pointer component, it has already been resolved. */
3102 if (gfc_is_proc_ptr_comp (expr
))
3105 if (sym
&& sym
->attr
.intrinsic
3106 && gfc_resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3109 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3111 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3115 /* If this ia a deferred TBP with an abstract interface (which may
3116 of course be referenced), expr->value.function.esym will be set. */
3117 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3119 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3120 sym
->name
, &expr
->where
);
3124 /* Switch off assumed size checking and do this again for certain kinds
3125 of procedure, once the procedure itself is resolved. */
3126 need_full_assumed_size
++;
3128 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3129 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3131 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3132 inquiry_argument
= true;
3133 no_formal_args
= sym
&& is_external_proc (sym
)
3134 && gfc_sym_get_dummy_args (sym
) == NULL
;
3136 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3137 p
, no_formal_args
) == FAILURE
)
3139 inquiry_argument
= false;
3143 inquiry_argument
= false;
3145 /* Need to setup the call to the correct c_associated, depending on
3146 the number of cptrs to user gives to compare. */
3147 if (sym
&& sym
->attr
.is_iso_c
== 1)
3149 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3153 /* Get the symtree for the new symbol (resolved func).
3154 the old one will be freed later, when it's no longer used. */
3155 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3158 /* Resume assumed_size checking. */
3159 need_full_assumed_size
--;
3161 /* If the procedure is external, check for usage. */
3162 if (sym
&& is_external_proc (sym
))
3163 resolve_global_procedure (sym
, &expr
->where
,
3164 &expr
->value
.function
.actual
, 0);
3166 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3168 && sym
->ts
.u
.cl
->length
== NULL
3170 && !sym
->ts
.deferred
3171 && expr
->value
.function
.esym
== NULL
3172 && !sym
->attr
.contained
)
3174 /* Internal procedures are taken care of in resolve_contained_fntype. */
3175 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3176 "be used at %L since it is not a dummy argument",
3177 sym
->name
, &expr
->where
);
3181 /* See if function is already resolved. */
3183 if (expr
->value
.function
.name
!= NULL
)
3185 if (expr
->ts
.type
== BT_UNKNOWN
)
3191 /* Apply the rules of section 14.1.2. */
3193 switch (procedure_kind (sym
))
3196 t
= resolve_generic_f (expr
);
3199 case PTYPE_SPECIFIC
:
3200 t
= resolve_specific_f (expr
);
3204 t
= resolve_unknown_f (expr
);
3208 gfc_internal_error ("resolve_function(): bad function type");
3212 /* If the expression is still a function (it might have simplified),
3213 then we check to see if we are calling an elemental function. */
3215 if (expr
->expr_type
!= EXPR_FUNCTION
)
3218 temp
= need_full_assumed_size
;
3219 need_full_assumed_size
= 0;
3221 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3224 if (omp_workshare_flag
3225 && expr
->value
.function
.esym
3226 && ! gfc_elemental (expr
->value
.function
.esym
))
3228 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3229 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3234 #define GENERIC_ID expr->value.function.isym->id
3235 else if (expr
->value
.function
.actual
!= NULL
3236 && expr
->value
.function
.isym
!= NULL
3237 && GENERIC_ID
!= GFC_ISYM_LBOUND
3238 && GENERIC_ID
!= GFC_ISYM_LEN
3239 && GENERIC_ID
!= GFC_ISYM_LOC
3240 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3242 /* Array intrinsics must also have the last upper bound of an
3243 assumed size array argument. UBOUND and SIZE have to be
3244 excluded from the check if the second argument is anything
3247 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3249 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3250 && arg
->next
!= NULL
&& arg
->next
->expr
)
3252 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3255 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3258 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3263 if (arg
->expr
!= NULL
3264 && arg
->expr
->rank
> 0
3265 && resolve_assumed_size_actual (arg
->expr
))
3271 need_full_assumed_size
= temp
;
3274 if (!pure_function (expr
, &name
) && name
)
3278 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3279 "FORALL %s", name
, &expr
->where
,
3280 forall_flag
== 2 ? "mask" : "block");
3283 else if (do_concurrent_flag
)
3285 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3286 "DO CONCURRENT %s", name
, &expr
->where
,
3287 do_concurrent_flag
== 2 ? "mask" : "block");
3290 else if (gfc_pure (NULL
))
3292 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3293 "procedure within a PURE procedure", name
, &expr
->where
);
3297 if (gfc_implicit_pure (NULL
))
3298 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3301 /* Functions without the RECURSIVE attribution are not allowed to
3302 * call themselves. */
3303 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3306 esym
= expr
->value
.function
.esym
;
3308 if (is_illegal_recursion (esym
, gfc_current_ns
))
3310 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3311 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3312 " function '%s' is not RECURSIVE",
3313 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3315 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3316 " is not RECURSIVE", esym
->name
, &expr
->where
);
3322 /* Character lengths of use associated functions may contains references to
3323 symbols not referenced from the current program unit otherwise. Make sure
3324 those symbols are marked as referenced. */
3326 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3327 && expr
->value
.function
.esym
->attr
.use_assoc
)
3329 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3332 /* Make sure that the expression has a typespec that works. */
3333 if (expr
->ts
.type
== BT_UNKNOWN
)
3335 if (expr
->symtree
->n
.sym
->result
3336 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3337 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3338 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3345 /************* Subroutine resolution *************/
3348 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3354 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3355 sym
->name
, &c
->loc
);
3356 else if (do_concurrent_flag
)
3357 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3358 "PURE", sym
->name
, &c
->loc
);
3359 else if (gfc_pure (NULL
))
3360 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3363 if (gfc_implicit_pure (NULL
))
3364 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3369 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3373 if (sym
->attr
.generic
)
3375 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3378 c
->resolved_sym
= s
;
3379 pure_subroutine (c
, s
);
3383 /* TODO: Need to search for elemental references in generic interface. */
3386 if (sym
->attr
.intrinsic
)
3387 return gfc_intrinsic_sub_interface (c
, 0);
3394 resolve_generic_s (gfc_code
*c
)
3399 sym
= c
->symtree
->n
.sym
;
3403 m
= resolve_generic_s0 (c
, sym
);
3406 else if (m
== MATCH_ERROR
)
3410 if (sym
->ns
->parent
== NULL
)
3412 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3416 if (!generic_sym (sym
))
3420 /* Last ditch attempt. See if the reference is to an intrinsic
3421 that possesses a matching interface. 14.1.2.4 */
3422 sym
= c
->symtree
->n
.sym
;
3424 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3426 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3427 sym
->name
, &c
->loc
);
3431 m
= gfc_intrinsic_sub_interface (c
, 0);
3435 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3436 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3442 /* Set the name and binding label of the subroutine symbol in the call
3443 expression represented by 'c' to include the type and kind of the
3444 second parameter. This function is for resolving the appropriate
3445 version of c_f_pointer() and c_f_procpointer(). For example, a
3446 call to c_f_pointer() for a default integer pointer could have a
3447 name of c_f_pointer_i4. If no second arg exists, which is an error
3448 for these two functions, it defaults to the generic symbol's name
3449 and binding label. */
3452 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3453 char *name
, const char **binding_label
)
3455 gfc_expr
*arg
= NULL
;
3459 /* The second arg of c_f_pointer and c_f_procpointer determines
3460 the type and kind for the procedure name. */
3461 arg
= c
->ext
.actual
->next
->expr
;
3465 /* Set up the name to have the given symbol's name,
3466 plus the type and kind. */
3467 /* a derived type is marked with the type letter 'u' */
3468 if (arg
->ts
.type
== BT_DERIVED
)
3471 kind
= 0; /* set the kind as 0 for now */
3475 type
= gfc_type_letter (arg
->ts
.type
);
3476 kind
= arg
->ts
.kind
;
3479 if (arg
->ts
.type
== BT_CHARACTER
)
3480 /* Kind info for character strings not needed. */
3483 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3484 /* Set up the binding label as the given symbol's label plus
3485 the type and kind. */
3486 *binding_label
= gfc_get_string ("%s_%c%d", sym
->binding_label
, type
,
3491 /* If the second arg is missing, set the name and label as
3492 was, cause it should at least be found, and the missing
3493 arg error will be caught by compare_parameters(). */
3494 sprintf (name
, "%s", sym
->name
);
3495 *binding_label
= sym
->binding_label
;
3502 /* Resolve a generic version of the iso_c_binding procedure given
3503 (sym) to the specific one based on the type and kind of the
3504 argument(s). Currently, this function resolves c_f_pointer() and
3505 c_f_procpointer based on the type and kind of the second argument
3506 (FPTR). Other iso_c_binding procedures aren't specially handled.
3507 Upon successfully exiting, c->resolved_sym will hold the resolved
3508 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3512 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3514 gfc_symbol
*new_sym
;
3515 /* this is fine, since we know the names won't use the max */
3516 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3517 const char* binding_label
;
3518 /* default to success; will override if find error */
3519 match m
= MATCH_YES
;
3521 /* Make sure the actual arguments are in the necessary order (based on the
3522 formal args) before resolving. */
3523 if (gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
)) == FAILURE
)
3525 c
->resolved_sym
= sym
;
3529 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3530 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3532 set_name_and_label (c
, sym
, name
, &binding_label
);
3534 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3536 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3538 gfc_actual_arglist
*arg1
= c
->ext
.actual
;
3539 gfc_actual_arglist
*arg2
= c
->ext
.actual
->next
;
3540 gfc_actual_arglist
*arg3
= c
->ext
.actual
->next
->next
;
3542 /* Check first argument (CPTR). */
3543 if (arg1
->expr
->ts
.type
!= BT_DERIVED
3544 || arg1
->expr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
3546 gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
3547 "the type C_PTR", &arg1
->expr
->where
);
3551 /* Check second argument (FPTR). */
3552 if (arg2
->expr
->ts
.type
== BT_CLASS
)
3554 gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
3555 "polymorphic", &arg2
->expr
->where
);
3559 /* Make sure we got a third arg (SHAPE) if the second arg has
3560 non-zero rank. We must also check that the type and rank are
3561 correct since we short-circuit this check in
3562 gfc_procedure_use() (called above to sort actual args). */
3563 if (arg2
->expr
->rank
!= 0)
3565 if (arg3
== NULL
|| arg3
->expr
== NULL
)
3568 gfc_error ("Missing SHAPE argument for call to %s at %L",
3569 sym
->name
, &c
->loc
);
3571 else if (arg3
->expr
->ts
.type
!= BT_INTEGER
3572 || arg3
->expr
->rank
!= 1)
3575 gfc_error ("SHAPE argument for call to %s at %L must be "
3576 "a rank 1 INTEGER array", sym
->name
, &c
->loc
);
3581 else /* ISOCBINDING_F_PROCPOINTER. */
3584 && (c
->ext
.actual
->expr
->ts
.type
!= BT_DERIVED
3585 || c
->ext
.actual
->expr
->ts
.u
.derived
->intmod_sym_id
3586 != ISOCBINDING_FUNPTR
))
3588 gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
3589 "C_FUNPTR", &c
->ext
.actual
->expr
->where
);
3592 if (c
->ext
.actual
&& c
->ext
.actual
->next
3593 && !gfc_expr_attr (c
->ext
.actual
->next
->expr
).is_bind_c
3594 && gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable "
3595 "procedure-pointer at %L to C_F_FUNPOINTER",
3596 &c
->ext
.actual
->next
->expr
->where
)
3601 if (m
!= MATCH_ERROR
)
3603 /* the 1 means to add the optional arg to formal list */
3604 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3606 /* for error reporting, say it's declared where the original was */
3607 new_sym
->declared_at
= sym
->declared_at
;
3612 /* no differences for c_loc or c_funloc */
3616 /* set the resolved symbol */
3617 if (m
!= MATCH_ERROR
)
3618 c
->resolved_sym
= new_sym
;
3620 c
->resolved_sym
= sym
;
3626 /* Resolve a subroutine call known to be specific. */
3629 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3633 if(sym
->attr
.is_iso_c
)
3635 m
= gfc_iso_c_sub_interface (c
,sym
);
3639 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3641 if (sym
->attr
.dummy
)
3643 sym
->attr
.proc
= PROC_DUMMY
;
3647 sym
->attr
.proc
= PROC_EXTERNAL
;
3651 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3654 if (sym
->attr
.intrinsic
)
3656 m
= gfc_intrinsic_sub_interface (c
, 1);
3660 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3661 "with an intrinsic", sym
->name
, &c
->loc
);
3669 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3671 c
->resolved_sym
= sym
;
3672 pure_subroutine (c
, sym
);
3679 resolve_specific_s (gfc_code
*c
)
3684 sym
= c
->symtree
->n
.sym
;
3688 m
= resolve_specific_s0 (c
, sym
);
3691 if (m
== MATCH_ERROR
)
3694 if (sym
->ns
->parent
== NULL
)
3697 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3703 sym
= c
->symtree
->n
.sym
;
3704 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3705 sym
->name
, &c
->loc
);
3711 /* Resolve a subroutine call not known to be generic nor specific. */
3714 resolve_unknown_s (gfc_code
*c
)
3718 sym
= c
->symtree
->n
.sym
;
3720 if (sym
->attr
.dummy
)
3722 sym
->attr
.proc
= PROC_DUMMY
;
3726 /* See if we have an intrinsic function reference. */
3728 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3730 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3735 /* The reference is to an external name. */
3738 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3740 c
->resolved_sym
= sym
;
3742 pure_subroutine (c
, sym
);
3748 /* Resolve a subroutine call. Although it was tempting to use the same code
3749 for functions, subroutines and functions are stored differently and this
3750 makes things awkward. */
3753 resolve_call (gfc_code
*c
)
3756 procedure_type ptype
= PROC_INTRINSIC
;
3757 gfc_symbol
*csym
, *sym
;
3758 bool no_formal_args
;
3760 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3762 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3764 gfc_error ("'%s' at %L has a type, which is not consistent with "
3765 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3769 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3772 gfc_find_sym_tree (c
->symtree
->name
, gfc_current_ns
, 1, &st
);
3773 sym
= st
? st
->n
.sym
: NULL
;
3774 if (sym
&& csym
!= sym
3775 && sym
->ns
== gfc_current_ns
3776 && sym
->attr
.flavor
== FL_PROCEDURE
3777 && sym
->attr
.contained
)
3780 if (csym
->attr
.generic
)
3781 c
->symtree
->n
.sym
= sym
;
3784 csym
= c
->symtree
->n
.sym
;
3788 /* If this ia a deferred TBP with an abstract interface
3789 (which may of course be referenced), c->expr1 will be set. */
3790 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3792 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3793 csym
->name
, &c
->loc
);
3797 /* Subroutines without the RECURSIVE attribution are not allowed to
3798 * call themselves. */
3799 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3801 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3802 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3803 " subroutine '%s' is not RECURSIVE",
3804 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3806 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3807 " is not RECURSIVE", csym
->name
, &c
->loc
);
3812 /* Switch off assumed size checking and do this again for certain kinds
3813 of procedure, once the procedure itself is resolved. */
3814 need_full_assumed_size
++;
3817 ptype
= csym
->attr
.proc
;
3819 no_formal_args
= csym
&& is_external_proc (csym
)
3820 && gfc_sym_get_dummy_args (csym
) == NULL
;
3821 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3822 no_formal_args
) == FAILURE
)
3825 /* Resume assumed_size checking. */
3826 need_full_assumed_size
--;
3828 /* If external, check for usage. */
3829 if (csym
&& is_external_proc (csym
))
3830 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3833 if (c
->resolved_sym
== NULL
)
3835 c
->resolved_isym
= NULL
;
3836 switch (procedure_kind (csym
))
3839 t
= resolve_generic_s (c
);
3842 case PTYPE_SPECIFIC
:
3843 t
= resolve_specific_s (c
);
3847 t
= resolve_unknown_s (c
);
3851 gfc_internal_error ("resolve_subroutine(): bad function type");
3855 /* Some checks of elemental subroutine actual arguments. */
3856 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3863 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3864 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3865 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3866 if their shapes do not match. If either op1->shape or op2->shape is
3867 NULL, return SUCCESS. */
3870 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3877 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3879 for (i
= 0; i
< op1
->rank
; i
++)
3881 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3883 gfc_error ("Shapes for operands at %L and %L are not conformable",
3884 &op1
->where
, &op2
->where
);
3895 /* Resolve an operator expression node. This can involve replacing the
3896 operation with a user defined function call. */
3899 resolve_operator (gfc_expr
*e
)
3901 gfc_expr
*op1
, *op2
;
3903 bool dual_locus_error
;
3906 /* Resolve all subnodes-- give them types. */
3908 switch (e
->value
.op
.op
)
3911 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3914 /* Fall through... */
3917 case INTRINSIC_UPLUS
:
3918 case INTRINSIC_UMINUS
:
3919 case INTRINSIC_PARENTHESES
:
3920 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3925 /* Typecheck the new node. */
3927 op1
= e
->value
.op
.op1
;
3928 op2
= e
->value
.op
.op2
;
3929 dual_locus_error
= false;
3931 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3932 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3934 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3938 switch (e
->value
.op
.op
)
3940 case INTRINSIC_UPLUS
:
3941 case INTRINSIC_UMINUS
:
3942 if (op1
->ts
.type
== BT_INTEGER
3943 || op1
->ts
.type
== BT_REAL
3944 || op1
->ts
.type
== BT_COMPLEX
)
3950 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3951 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3954 case INTRINSIC_PLUS
:
3955 case INTRINSIC_MINUS
:
3956 case INTRINSIC_TIMES
:
3957 case INTRINSIC_DIVIDE
:
3958 case INTRINSIC_POWER
:
3959 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3961 gfc_type_convert_binary (e
, 1);
3966 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3967 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3968 gfc_typename (&op2
->ts
));
3971 case INTRINSIC_CONCAT
:
3972 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3973 && op1
->ts
.kind
== op2
->ts
.kind
)
3975 e
->ts
.type
= BT_CHARACTER
;
3976 e
->ts
.kind
= op1
->ts
.kind
;
3981 _("Operands of string concatenation operator at %%L are %s/%s"),
3982 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3988 case INTRINSIC_NEQV
:
3989 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3991 e
->ts
.type
= BT_LOGICAL
;
3992 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3993 if (op1
->ts
.kind
< e
->ts
.kind
)
3994 gfc_convert_type (op1
, &e
->ts
, 2);
3995 else if (op2
->ts
.kind
< e
->ts
.kind
)
3996 gfc_convert_type (op2
, &e
->ts
, 2);
4000 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
4001 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4002 gfc_typename (&op2
->ts
));
4007 if (op1
->ts
.type
== BT_LOGICAL
)
4009 e
->ts
.type
= BT_LOGICAL
;
4010 e
->ts
.kind
= op1
->ts
.kind
;
4014 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4015 gfc_typename (&op1
->ts
));
4019 case INTRINSIC_GT_OS
:
4021 case INTRINSIC_GE_OS
:
4023 case INTRINSIC_LT_OS
:
4025 case INTRINSIC_LE_OS
:
4026 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4028 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4032 /* Fall through... */
4035 case INTRINSIC_EQ_OS
:
4037 case INTRINSIC_NE_OS
:
4038 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4039 && op1
->ts
.kind
== op2
->ts
.kind
)
4041 e
->ts
.type
= BT_LOGICAL
;
4042 e
->ts
.kind
= gfc_default_logical_kind
;
4046 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4048 gfc_type_convert_binary (e
, 1);
4050 e
->ts
.type
= BT_LOGICAL
;
4051 e
->ts
.kind
= gfc_default_logical_kind
;
4053 if (gfc_option
.warn_compare_reals
)
4055 gfc_intrinsic_op op
= e
->value
.op
.op
;
4057 /* Type conversion has made sure that the types of op1 and op2
4058 agree, so it is only necessary to check the first one. */
4059 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4060 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4061 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4065 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4066 msg
= "Equality comparison for %s at %L";
4068 msg
= "Inequality comparison for %s at %L";
4070 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
4077 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4079 _("Logicals at %%L must be compared with %s instead of %s"),
4080 (e
->value
.op
.op
== INTRINSIC_EQ
4081 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4082 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4085 _("Operands of comparison operator '%s' at %%L are %s/%s"),
4086 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4087 gfc_typename (&op2
->ts
));
4091 case INTRINSIC_USER
:
4092 if (e
->value
.op
.uop
->op
== NULL
)
4093 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
4094 else if (op2
== NULL
)
4095 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
4096 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4099 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
4100 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4101 gfc_typename (&op2
->ts
));
4102 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4107 case INTRINSIC_PARENTHESES
:
4109 if (e
->ts
.type
== BT_CHARACTER
)
4110 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4114 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4117 /* Deal with arrayness of an operand through an operator. */
4121 switch (e
->value
.op
.op
)
4123 case INTRINSIC_PLUS
:
4124 case INTRINSIC_MINUS
:
4125 case INTRINSIC_TIMES
:
4126 case INTRINSIC_DIVIDE
:
4127 case INTRINSIC_POWER
:
4128 case INTRINSIC_CONCAT
:
4132 case INTRINSIC_NEQV
:
4134 case INTRINSIC_EQ_OS
:
4136 case INTRINSIC_NE_OS
:
4138 case INTRINSIC_GT_OS
:
4140 case INTRINSIC_GE_OS
:
4142 case INTRINSIC_LT_OS
:
4144 case INTRINSIC_LE_OS
:
4146 if (op1
->rank
== 0 && op2
->rank
== 0)
4149 if (op1
->rank
== 0 && op2
->rank
!= 0)
4151 e
->rank
= op2
->rank
;
4153 if (e
->shape
== NULL
)
4154 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4157 if (op1
->rank
!= 0 && op2
->rank
== 0)
4159 e
->rank
= op1
->rank
;
4161 if (e
->shape
== NULL
)
4162 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4165 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4167 if (op1
->rank
== op2
->rank
)
4169 e
->rank
= op1
->rank
;
4170 if (e
->shape
== NULL
)
4172 t
= compare_shapes (op1
, op2
);
4176 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4181 /* Allow higher level expressions to work. */
4184 /* Try user-defined operators, and otherwise throw an error. */
4185 dual_locus_error
= true;
4187 _("Inconsistent ranks for operator at %%L and %%L"));
4194 case INTRINSIC_PARENTHESES
:
4196 case INTRINSIC_UPLUS
:
4197 case INTRINSIC_UMINUS
:
4198 /* Simply copy arrayness attribute */
4199 e
->rank
= op1
->rank
;
4201 if (e
->shape
== NULL
)
4202 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4210 /* Attempt to simplify the expression. */
4213 t
= gfc_simplify_expr (e
, 0);
4214 /* Some calls do not succeed in simplification and return FAILURE
4215 even though there is no error; e.g. variable references to
4216 PARAMETER arrays. */
4217 if (!gfc_is_constant_expr (e
))
4225 match m
= gfc_extend_expr (e
);
4228 if (m
== MATCH_ERROR
)
4232 if (dual_locus_error
)
4233 gfc_error (msg
, &op1
->where
, &op2
->where
);
4235 gfc_error (msg
, &e
->where
);
4241 /************** Array resolution subroutines **************/
4244 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4247 /* Compare two integer expressions. */
4250 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4254 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4255 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4258 /* If either of the types isn't INTEGER, we must have
4259 raised an error earlier. */
4261 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4264 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4274 /* Compare an integer expression with an integer. */
4277 compare_bound_int (gfc_expr
*a
, int b
)
4281 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4284 if (a
->ts
.type
!= BT_INTEGER
)
4285 gfc_internal_error ("compare_bound_int(): Bad expression");
4287 i
= mpz_cmp_si (a
->value
.integer
, b
);
4297 /* Compare an integer expression with a mpz_t. */
4300 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4304 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4307 if (a
->ts
.type
!= BT_INTEGER
)
4308 gfc_internal_error ("compare_bound_int(): Bad expression");
4310 i
= mpz_cmp (a
->value
.integer
, b
);
4320 /* Compute the last value of a sequence given by a triplet.
4321 Return 0 if it wasn't able to compute the last value, or if the
4322 sequence if empty, and 1 otherwise. */
4325 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4326 gfc_expr
*stride
, mpz_t last
)
4330 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4331 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4332 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4335 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4336 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4339 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4341 if (compare_bound (start
, end
) == CMP_GT
)
4343 mpz_set (last
, end
->value
.integer
);
4347 if (compare_bound_int (stride
, 0) == CMP_GT
)
4349 /* Stride is positive */
4350 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4355 /* Stride is negative */
4356 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4361 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4362 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4363 mpz_sub (last
, end
->value
.integer
, rem
);
4370 /* Compare a single dimension of an array reference to the array
4374 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4378 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4380 gcc_assert (ar
->stride
[i
] == NULL
);
4381 /* This implies [*] as [*:] and [*:3] are not possible. */
4382 if (ar
->start
[i
] == NULL
)
4384 gcc_assert (ar
->end
[i
] == NULL
);
4389 /* Given start, end and stride values, calculate the minimum and
4390 maximum referenced indexes. */
4392 switch (ar
->dimen_type
[i
])
4395 case DIMEN_THIS_IMAGE
:
4400 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4403 gfc_warning ("Array reference at %L is out of bounds "
4404 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4405 mpz_get_si (ar
->start
[i
]->value
.integer
),
4406 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4408 gfc_warning ("Array reference at %L is out of bounds "
4409 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4410 mpz_get_si (ar
->start
[i
]->value
.integer
),
4411 mpz_get_si (as
->lower
[i
]->value
.integer
),
4415 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4418 gfc_warning ("Array reference at %L is out of bounds "
4419 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4420 mpz_get_si (ar
->start
[i
]->value
.integer
),
4421 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4423 gfc_warning ("Array reference at %L is out of bounds "
4424 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4425 mpz_get_si (ar
->start
[i
]->value
.integer
),
4426 mpz_get_si (as
->upper
[i
]->value
.integer
),
4435 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4436 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4438 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4440 /* Check for zero stride, which is not allowed. */
4441 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4443 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4447 /* if start == len || (stride > 0 && start < len)
4448 || (stride < 0 && start > len),
4449 then the array section contains at least one element. In this
4450 case, there is an out-of-bounds access if
4451 (start < lower || start > upper). */
4452 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4453 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4454 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4455 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4456 && comp_start_end
== CMP_GT
))
4458 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4460 gfc_warning ("Lower array reference at %L is out of bounds "
4461 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4462 mpz_get_si (AR_START
->value
.integer
),
4463 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4466 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4468 gfc_warning ("Lower array reference at %L is out of bounds "
4469 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4470 mpz_get_si (AR_START
->value
.integer
),
4471 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4476 /* If we can compute the highest index of the array section,
4477 then it also has to be between lower and upper. */
4478 mpz_init (last_value
);
4479 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4482 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4484 gfc_warning ("Upper array reference at %L is out of bounds "
4485 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4486 mpz_get_si (last_value
),
4487 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4488 mpz_clear (last_value
);
4491 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4493 gfc_warning ("Upper array reference at %L is out of bounds "
4494 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4495 mpz_get_si (last_value
),
4496 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4497 mpz_clear (last_value
);
4501 mpz_clear (last_value
);
4509 gfc_internal_error ("check_dimension(): Bad array reference");
4516 /* Compare an array reference with an array specification. */
4519 compare_spec_to_ref (gfc_array_ref
*ar
)
4526 /* TODO: Full array sections are only allowed as actual parameters. */
4527 if (as
->type
== AS_ASSUMED_SIZE
4528 && (/*ar->type == AR_FULL
4529 ||*/ (ar
->type
== AR_SECTION
4530 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4532 gfc_error ("Rightmost upper bound of assumed size array section "
4533 "not specified at %L", &ar
->where
);
4537 if (ar
->type
== AR_FULL
)
4540 if (as
->rank
!= ar
->dimen
)
4542 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4543 &ar
->where
, ar
->dimen
, as
->rank
);
4547 /* ar->codimen == 0 is a local array. */
4548 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4550 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4551 &ar
->where
, ar
->codimen
, as
->corank
);
4555 for (i
= 0; i
< as
->rank
; i
++)
4556 if (check_dimension (i
, ar
, as
) == FAILURE
)
4559 /* Local access has no coarray spec. */
4560 if (ar
->codimen
!= 0)
4561 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4563 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4564 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4566 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4567 i
+ 1 - as
->rank
, &ar
->where
);
4570 if (check_dimension (i
, ar
, as
) == FAILURE
)
4578 /* Resolve one part of an array index. */
4581 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4582 int force_index_integer_kind
)
4589 if (gfc_resolve_expr (index
) == FAILURE
)
4592 if (check_scalar
&& index
->rank
!= 0)
4594 gfc_error ("Array index at %L must be scalar", &index
->where
);
4598 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4600 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4601 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4605 if (index
->ts
.type
== BT_REAL
)
4606 if (gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4607 &index
->where
) == FAILURE
)
4610 if ((index
->ts
.kind
!= gfc_index_integer_kind
4611 && force_index_integer_kind
)
4612 || index
->ts
.type
!= BT_INTEGER
)
4615 ts
.type
= BT_INTEGER
;
4616 ts
.kind
= gfc_index_integer_kind
;
4618 gfc_convert_type_warn (index
, &ts
, 2, 0);
4624 /* Resolve one part of an array index. */
4627 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4629 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4632 /* Resolve a dim argument to an intrinsic function. */
4635 gfc_resolve_dim_arg (gfc_expr
*dim
)
4640 if (gfc_resolve_expr (dim
) == FAILURE
)
4645 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4650 if (dim
->ts
.type
!= BT_INTEGER
)
4652 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4656 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4661 ts
.type
= BT_INTEGER
;
4662 ts
.kind
= gfc_index_integer_kind
;
4664 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4670 /* Given an expression that contains array references, update those array
4671 references to point to the right array specifications. While this is
4672 filled in during matching, this information is difficult to save and load
4673 in a module, so we take care of it here.
4675 The idea here is that the original array reference comes from the
4676 base symbol. We traverse the list of reference structures, setting
4677 the stored reference to references. Component references can
4678 provide an additional array specification. */
4681 find_array_spec (gfc_expr
*e
)
4687 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4688 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4690 as
= e
->symtree
->n
.sym
->as
;
4692 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4697 gfc_internal_error ("find_array_spec(): Missing spec");
4704 c
= ref
->u
.c
.component
;
4705 if (c
->attr
.dimension
)
4708 gfc_internal_error ("find_array_spec(): unused as(1)");
4719 gfc_internal_error ("find_array_spec(): unused as(2)");
4723 /* Resolve an array reference. */
4726 resolve_array_ref (gfc_array_ref
*ar
)
4728 int i
, check_scalar
;
4731 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4733 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4735 /* Do not force gfc_index_integer_kind for the start. We can
4736 do fine with any integer kind. This avoids temporary arrays
4737 created for indexing with a vector. */
4738 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4740 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4742 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4747 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4751 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4755 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4756 if (e
->expr_type
== EXPR_VARIABLE
4757 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4758 ar
->start
[i
] = gfc_get_parentheses (e
);
4762 gfc_error ("Array index at %L is an array of rank %d",
4763 &ar
->c_where
[i
], e
->rank
);
4767 /* Fill in the upper bound, which may be lower than the
4768 specified one for something like a(2:10:5), which is
4769 identical to a(2:7:5). Only relevant for strides not equal
4770 to one. Don't try a division by zero. */
4771 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4772 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4773 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4774 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4778 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4780 if (ar
->end
[i
] == NULL
)
4783 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4785 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4787 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4788 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4790 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4801 if (ar
->type
== AR_FULL
)
4803 if (ar
->as
->rank
== 0)
4804 ar
->type
= AR_ELEMENT
;
4806 /* Make sure array is the same as array(:,:), this way
4807 we don't need to special case all the time. */
4808 ar
->dimen
= ar
->as
->rank
;
4809 for (i
= 0; i
< ar
->dimen
; i
++)
4811 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4813 gcc_assert (ar
->start
[i
] == NULL
);
4814 gcc_assert (ar
->end
[i
] == NULL
);
4815 gcc_assert (ar
->stride
[i
] == NULL
);
4819 /* If the reference type is unknown, figure out what kind it is. */
4821 if (ar
->type
== AR_UNKNOWN
)
4823 ar
->type
= AR_ELEMENT
;
4824 for (i
= 0; i
< ar
->dimen
; i
++)
4825 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4826 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4828 ar
->type
= AR_SECTION
;
4833 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4836 if (ar
->as
->corank
&& ar
->codimen
== 0)
4839 ar
->codimen
= ar
->as
->corank
;
4840 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4841 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4849 resolve_substring (gfc_ref
*ref
)
4851 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4853 if (ref
->u
.ss
.start
!= NULL
)
4855 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4858 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4860 gfc_error ("Substring start index at %L must be of type INTEGER",
4861 &ref
->u
.ss
.start
->where
);
4865 if (ref
->u
.ss
.start
->rank
!= 0)
4867 gfc_error ("Substring start index at %L must be scalar",
4868 &ref
->u
.ss
.start
->where
);
4872 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4873 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4874 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4876 gfc_error ("Substring start index at %L is less than one",
4877 &ref
->u
.ss
.start
->where
);
4882 if (ref
->u
.ss
.end
!= NULL
)
4884 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4887 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4889 gfc_error ("Substring end index at %L must be of type INTEGER",
4890 &ref
->u
.ss
.end
->where
);
4894 if (ref
->u
.ss
.end
->rank
!= 0)
4896 gfc_error ("Substring end index at %L must be scalar",
4897 &ref
->u
.ss
.end
->where
);
4901 if (ref
->u
.ss
.length
!= NULL
4902 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4903 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4904 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4906 gfc_error ("Substring end index at %L exceeds the string length",
4907 &ref
->u
.ss
.start
->where
);
4911 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4912 gfc_integer_kinds
[k
].huge
) == CMP_GT
4913 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4914 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4916 gfc_error ("Substring end index at %L is too large",
4917 &ref
->u
.ss
.end
->where
);
4926 /* This function supplies missing substring charlens. */
4929 gfc_resolve_substring_charlen (gfc_expr
*e
)
4932 gfc_expr
*start
, *end
;
4934 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4935 if (char_ref
->type
== REF_SUBSTRING
)
4941 gcc_assert (char_ref
->next
== NULL
);
4945 if (e
->ts
.u
.cl
->length
)
4946 gfc_free_expr (e
->ts
.u
.cl
->length
);
4947 else if (e
->expr_type
== EXPR_VARIABLE
4948 && e
->symtree
->n
.sym
->attr
.dummy
)
4952 e
->ts
.type
= BT_CHARACTER
;
4953 e
->ts
.kind
= gfc_default_character_kind
;
4956 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4958 if (char_ref
->u
.ss
.start
)
4959 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4961 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4963 if (char_ref
->u
.ss
.end
)
4964 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4965 else if (e
->expr_type
== EXPR_VARIABLE
)
4966 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4972 gfc_free_expr (start
);
4973 gfc_free_expr (end
);
4977 /* Length = (end - start +1). */
4978 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4979 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4980 gfc_get_int_expr (gfc_default_integer_kind
,
4983 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4984 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4986 /* Make sure that the length is simplified. */
4987 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4988 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4992 /* Resolve subtype references. */
4995 resolve_ref (gfc_expr
*expr
)
4997 int current_part_dimension
, n_components
, seen_part_dimension
;
5000 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5001 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5003 find_array_spec (expr
);
5007 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5011 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
5019 if (resolve_substring (ref
) == FAILURE
)
5024 /* Check constraints on part references. */
5026 current_part_dimension
= 0;
5027 seen_part_dimension
= 0;
5030 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5035 switch (ref
->u
.ar
.type
)
5038 /* Coarray scalar. */
5039 if (ref
->u
.ar
.as
->rank
== 0)
5041 current_part_dimension
= 0;
5046 current_part_dimension
= 1;
5050 current_part_dimension
= 0;
5054 gfc_internal_error ("resolve_ref(): Bad array reference");
5060 if (current_part_dimension
|| seen_part_dimension
)
5063 if (ref
->u
.c
.component
->attr
.pointer
5064 || ref
->u
.c
.component
->attr
.proc_pointer
5065 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5066 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5068 gfc_error ("Component to the right of a part reference "
5069 "with nonzero rank must not have the POINTER "
5070 "attribute at %L", &expr
->where
);
5073 else if (ref
->u
.c
.component
->attr
.allocatable
5074 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5075 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5078 gfc_error ("Component to the right of a part reference "
5079 "with nonzero rank must not have the ALLOCATABLE "
5080 "attribute at %L", &expr
->where
);
5092 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5093 || ref
->next
== NULL
)
5094 && current_part_dimension
5095 && seen_part_dimension
)
5097 gfc_error ("Two or more part references with nonzero rank must "
5098 "not be specified at %L", &expr
->where
);
5102 if (ref
->type
== REF_COMPONENT
)
5104 if (current_part_dimension
)
5105 seen_part_dimension
= 1;
5107 /* reset to make sure */
5108 current_part_dimension
= 0;
5116 /* Given an expression, determine its shape. This is easier than it sounds.
5117 Leaves the shape array NULL if it is not possible to determine the shape. */
5120 expression_shape (gfc_expr
*e
)
5122 mpz_t array
[GFC_MAX_DIMENSIONS
];
5125 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5128 for (i
= 0; i
< e
->rank
; i
++)
5129 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
5132 e
->shape
= gfc_get_shape (e
->rank
);
5134 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5139 for (i
--; i
>= 0; i
--)
5140 mpz_clear (array
[i
]);
5144 /* Given a variable expression node, compute the rank of the expression by
5145 examining the base symbol and any reference structures it may have. */
5148 expression_rank (gfc_expr
*e
)
5153 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5154 could lead to serious confusion... */
5155 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5159 if (e
->expr_type
== EXPR_ARRAY
)
5161 /* Constructors can have a rank different from one via RESHAPE(). */
5163 if (e
->symtree
== NULL
)
5169 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5170 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5176 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5178 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5179 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5180 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5182 if (ref
->type
!= REF_ARRAY
)
5185 if (ref
->u
.ar
.type
== AR_FULL
)
5187 rank
= ref
->u
.ar
.as
->rank
;
5191 if (ref
->u
.ar
.type
== AR_SECTION
)
5193 /* Figure out the rank of the section. */
5195 gfc_internal_error ("expression_rank(): Two array specs");
5197 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5198 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5199 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5209 expression_shape (e
);
5213 /* Resolve a variable expression. */
5216 resolve_variable (gfc_expr
*e
)
5223 if (e
->symtree
== NULL
)
5225 sym
= e
->symtree
->n
.sym
;
5227 /* TS 29113, 407b. */
5228 if (e
->ts
.type
== BT_ASSUMED
)
5232 gfc_error ("Assumed-type variable %s at %L may only be used "
5233 "as actual argument", sym
->name
, &e
->where
);
5236 else if (inquiry_argument
&& !first_actual_arg
)
5238 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5239 for all inquiry functions in resolve_function; the reason is
5240 that the function-name resolution happens too late in that
5242 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5243 "an inquiry function shall be the first argument",
5244 sym
->name
, &e
->where
);
5249 /* TS 29113, C535b. */
5250 if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5251 && CLASS_DATA (sym
)->as
5252 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5253 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5254 && sym
->as
->type
== AS_ASSUMED_RANK
))
5258 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5259 "actual argument", sym
->name
, &e
->where
);
5262 else if (inquiry_argument
&& !first_actual_arg
)
5264 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5265 for all inquiry functions in resolve_function; the reason is
5266 that the function-name resolution happens too late in that
5268 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5269 "to an inquiry function shall be the first argument",
5270 sym
->name
, &e
->where
);
5275 /* TS 29113, 407b. */
5276 if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5277 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5278 && e
->ref
->next
== NULL
))
5280 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5281 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5285 /* TS 29113, C535b. */
5286 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5287 && CLASS_DATA (sym
)->as
5288 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5289 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5290 && sym
->as
->type
== AS_ASSUMED_RANK
))
5292 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5293 && e
->ref
->next
== NULL
))
5295 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5296 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5301 /* If this is an associate-name, it may be parsed with an array reference
5302 in error even though the target is scalar. Fail directly in this case.
5303 TODO Understand why class scalar expressions must be excluded. */
5304 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5306 if (sym
->ts
.type
== BT_CLASS
)
5307 gfc_fix_class_refs (e
);
5308 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5312 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5313 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5315 /* On the other hand, the parser may not have known this is an array;
5316 in this case, we have to add a FULL reference. */
5317 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5319 e
->ref
= gfc_get_ref ();
5320 e
->ref
->type
= REF_ARRAY
;
5321 e
->ref
->u
.ar
.type
= AR_FULL
;
5322 e
->ref
->u
.ar
.dimen
= 0;
5325 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5328 if (sym
->attr
.flavor
== FL_PROCEDURE
5329 && (!sym
->attr
.function
5330 || (sym
->attr
.function
&& sym
->result
5331 && sym
->result
->attr
.proc_pointer
5332 && !sym
->result
->attr
.function
)))
5334 e
->ts
.type
= BT_PROCEDURE
;
5335 goto resolve_procedure
;
5338 if (sym
->ts
.type
!= BT_UNKNOWN
)
5339 gfc_variable_attr (e
, &e
->ts
);
5342 /* Must be a simple variable reference. */
5343 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5348 if (check_assumed_size_reference (sym
, e
))
5351 /* Deal with forward references to entries during resolve_code, to
5352 satisfy, at least partially, 12.5.2.5. */
5353 if (gfc_current_ns
->entries
5354 && current_entry_id
== sym
->entry_id
5357 && cs_base
->current
->op
!= EXEC_ENTRY
)
5359 gfc_entry_list
*entry
;
5360 gfc_formal_arglist
*formal
;
5362 bool seen
, saved_specification_expr
;
5364 /* If the symbol is a dummy... */
5365 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5367 entry
= gfc_current_ns
->entries
;
5370 /* ...test if the symbol is a parameter of previous entries. */
5371 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5372 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5374 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5378 /* If it has not been seen as a dummy, this is an error. */
5381 if (specification_expr
)
5382 gfc_error ("Variable '%s', used in a specification expression"
5383 ", is referenced at %L before the ENTRY statement "
5384 "in which it is a parameter",
5385 sym
->name
, &cs_base
->current
->loc
);
5387 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5388 "statement in which it is a parameter",
5389 sym
->name
, &cs_base
->current
->loc
);
5394 /* Now do the same check on the specification expressions. */
5395 saved_specification_expr
= specification_expr
;
5396 specification_expr
= true;
5397 if (sym
->ts
.type
== BT_CHARACTER
5398 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5402 for (n
= 0; n
< sym
->as
->rank
; n
++)
5404 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5406 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5409 specification_expr
= saved_specification_expr
;
5412 /* Update the symbol's entry level. */
5413 sym
->entry_id
= current_entry_id
+ 1;
5416 /* If a symbol has been host_associated mark it. This is used latter,
5417 to identify if aliasing is possible via host association. */
5418 if (sym
->attr
.flavor
== FL_VARIABLE
5419 && gfc_current_ns
->parent
5420 && (gfc_current_ns
->parent
== sym
->ns
5421 || (gfc_current_ns
->parent
->parent
5422 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5423 sym
->attr
.host_assoc
= 1;
5426 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5429 /* F2008, C617 and C1229. */
5430 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5431 && gfc_is_coindexed (e
))
5433 gfc_ref
*ref
, *ref2
= NULL
;
5435 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5437 if (ref
->type
== REF_COMPONENT
)
5439 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5443 for ( ; ref
; ref
= ref
->next
)
5444 if (ref
->type
== REF_COMPONENT
)
5447 /* Expression itself is not coindexed object. */
5448 if (ref
&& e
->ts
.type
== BT_CLASS
)
5450 gfc_error ("Polymorphic subobject of coindexed object at %L",
5455 /* Expression itself is coindexed object. */
5459 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5460 for ( ; c
; c
= c
->next
)
5461 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5463 gfc_error ("Coindexed object with polymorphic allocatable "
5464 "subcomponent at %L", &e
->where
);
5475 /* Checks to see that the correct symbol has been host associated.
5476 The only situation where this arises is that in which a twice
5477 contained function is parsed after the host association is made.
5478 Therefore, on detecting this, change the symbol in the expression
5479 and convert the array reference into an actual arglist if the old
5480 symbol is a variable. */
5482 check_host_association (gfc_expr
*e
)
5484 gfc_symbol
*sym
, *old_sym
;
5488 gfc_actual_arglist
*arg
, *tail
= NULL
;
5489 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5491 /* If the expression is the result of substitution in
5492 interface.c(gfc_extend_expr) because there is no way in
5493 which the host association can be wrong. */
5494 if (e
->symtree
== NULL
5495 || e
->symtree
->n
.sym
== NULL
5496 || e
->user_operator
)
5499 old_sym
= e
->symtree
->n
.sym
;
5501 if (gfc_current_ns
->parent
5502 && old_sym
->ns
!= gfc_current_ns
)
5504 /* Use the 'USE' name so that renamed module symbols are
5505 correctly handled. */
5506 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5508 if (sym
&& old_sym
!= sym
5509 && sym
->ts
.type
== old_sym
->ts
.type
5510 && sym
->attr
.flavor
== FL_PROCEDURE
5511 && sym
->attr
.contained
)
5513 /* Clear the shape, since it might not be valid. */
5514 gfc_free_shape (&e
->shape
, e
->rank
);
5516 /* Give the expression the right symtree! */
5517 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5518 gcc_assert (st
!= NULL
);
5520 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5521 || e
->expr_type
== EXPR_FUNCTION
)
5523 /* Original was function so point to the new symbol, since
5524 the actual argument list is already attached to the
5526 e
->value
.function
.esym
= NULL
;
5531 /* Original was variable so convert array references into
5532 an actual arglist. This does not need any checking now
5533 since resolve_function will take care of it. */
5534 e
->value
.function
.actual
= NULL
;
5535 e
->expr_type
= EXPR_FUNCTION
;
5538 /* Ambiguity will not arise if the array reference is not
5539 the last reference. */
5540 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5541 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5544 gcc_assert (ref
->type
== REF_ARRAY
);
5546 /* Grab the start expressions from the array ref and
5547 copy them into actual arguments. */
5548 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5550 arg
= gfc_get_actual_arglist ();
5551 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5552 if (e
->value
.function
.actual
== NULL
)
5553 tail
= e
->value
.function
.actual
= arg
;
5561 /* Dump the reference list and set the rank. */
5562 gfc_free_ref_list (e
->ref
);
5564 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5567 gfc_resolve_expr (e
);
5571 /* This might have changed! */
5572 return e
->expr_type
== EXPR_FUNCTION
;
5577 gfc_resolve_character_operator (gfc_expr
*e
)
5579 gfc_expr
*op1
= e
->value
.op
.op1
;
5580 gfc_expr
*op2
= e
->value
.op
.op2
;
5581 gfc_expr
*e1
= NULL
;
5582 gfc_expr
*e2
= NULL
;
5584 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5586 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5587 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5588 else if (op1
->expr_type
== EXPR_CONSTANT
)
5589 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5590 op1
->value
.character
.length
);
5592 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5593 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5594 else if (op2
->expr_type
== EXPR_CONSTANT
)
5595 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5596 op2
->value
.character
.length
);
5598 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5608 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5609 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5610 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5611 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5612 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5618 /* Ensure that an character expression has a charlen and, if possible, a
5619 length expression. */
5622 fixup_charlen (gfc_expr
*e
)
5624 /* The cases fall through so that changes in expression type and the need
5625 for multiple fixes are picked up. In all circumstances, a charlen should
5626 be available for the middle end to hang a backend_decl on. */
5627 switch (e
->expr_type
)
5630 gfc_resolve_character_operator (e
);
5633 if (e
->expr_type
== EXPR_ARRAY
)
5634 gfc_resolve_character_array_constructor (e
);
5636 case EXPR_SUBSTRING
:
5637 if (!e
->ts
.u
.cl
&& e
->ref
)
5638 gfc_resolve_substring_charlen (e
);
5642 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5649 /* Update an actual argument to include the passed-object for type-bound
5650 procedures at the right position. */
5652 static gfc_actual_arglist
*
5653 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5656 gcc_assert (argpos
> 0);
5660 gfc_actual_arglist
* result
;
5662 result
= gfc_get_actual_arglist ();
5666 result
->name
= name
;
5672 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5674 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5679 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5682 extract_compcall_passed_object (gfc_expr
* e
)
5686 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5688 if (e
->value
.compcall
.base_object
)
5689 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5692 po
= gfc_get_expr ();
5693 po
->expr_type
= EXPR_VARIABLE
;
5694 po
->symtree
= e
->symtree
;
5695 po
->ref
= gfc_copy_ref (e
->ref
);
5696 po
->where
= e
->where
;
5699 if (gfc_resolve_expr (po
) == FAILURE
)
5706 /* Update the arglist of an EXPR_COMPCALL expression to include the
5710 update_compcall_arglist (gfc_expr
* e
)
5713 gfc_typebound_proc
* tbp
;
5715 tbp
= e
->value
.compcall
.tbp
;
5720 po
= extract_compcall_passed_object (e
);
5724 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5730 gcc_assert (tbp
->pass_arg_num
> 0);
5731 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5739 /* Extract the passed object from a PPC call (a copy of it). */
5742 extract_ppc_passed_object (gfc_expr
*e
)
5747 po
= gfc_get_expr ();
5748 po
->expr_type
= EXPR_VARIABLE
;
5749 po
->symtree
= e
->symtree
;
5750 po
->ref
= gfc_copy_ref (e
->ref
);
5751 po
->where
= e
->where
;
5753 /* Remove PPC reference. */
5755 while ((*ref
)->next
)
5756 ref
= &(*ref
)->next
;
5757 gfc_free_ref_list (*ref
);
5760 if (gfc_resolve_expr (po
) == FAILURE
)
5767 /* Update the actual arglist of a procedure pointer component to include the
5771 update_ppc_arglist (gfc_expr
* e
)
5775 gfc_typebound_proc
* tb
;
5777 ppc
= gfc_get_proc_ptr_comp (e
);
5785 else if (tb
->nopass
)
5788 po
= extract_ppc_passed_object (e
);
5795 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5800 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5802 gfc_error ("Base object for procedure-pointer component call at %L is of"
5803 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5807 gcc_assert (tb
->pass_arg_num
> 0);
5808 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5816 /* Check that the object a TBP is called on is valid, i.e. it must not be
5817 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5820 check_typebound_baseobject (gfc_expr
* e
)
5823 gfc_try return_value
= FAILURE
;
5825 base
= extract_compcall_passed_object (e
);
5829 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5831 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5835 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5837 gfc_error ("Base object for type-bound procedure call at %L is of"
5838 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5842 /* F08:C1230. If the procedure called is NOPASS,
5843 the base object must be scalar. */
5844 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5846 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5847 " be scalar", &e
->where
);
5851 return_value
= SUCCESS
;
5854 gfc_free_expr (base
);
5855 return return_value
;
5859 /* Resolve a call to a type-bound procedure, either function or subroutine,
5860 statically from the data in an EXPR_COMPCALL expression. The adapted
5861 arglist and the target-procedure symtree are returned. */
5864 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5865 gfc_actual_arglist
** actual
)
5867 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5868 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5870 /* Update the actual arglist for PASS. */
5871 if (update_compcall_arglist (e
) == FAILURE
)
5874 *actual
= e
->value
.compcall
.actual
;
5875 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5877 gfc_free_ref_list (e
->ref
);
5879 e
->value
.compcall
.actual
= NULL
;
5881 /* If we find a deferred typebound procedure, check for derived types
5882 that an overriding typebound procedure has not been missed. */
5883 if (e
->value
.compcall
.name
5884 && !e
->value
.compcall
.tbp
->non_overridable
5885 && e
->value
.compcall
.base_object
5886 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5889 gfc_symbol
*derived
;
5891 /* Use the derived type of the base_object. */
5892 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5895 /* If necessary, go through the inheritance chain. */
5896 while (!st
&& derived
)
5898 /* Look for the typebound procedure 'name'. */
5899 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5900 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5901 e
->value
.compcall
.name
);
5903 derived
= gfc_get_derived_super_type (derived
);
5906 /* Now find the specific name in the derived type namespace. */
5907 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5908 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5909 derived
->ns
, 1, &st
);
5917 /* Get the ultimate declared type from an expression. In addition,
5918 return the last class/derived type reference and the copy of the
5919 reference list. If check_types is set true, derived types are
5920 identified as well as class references. */
5922 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5923 gfc_expr
*e
, bool check_types
)
5925 gfc_symbol
*declared
;
5932 *new_ref
= gfc_copy_ref (e
->ref
);
5934 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5936 if (ref
->type
!= REF_COMPONENT
)
5939 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5940 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5941 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5943 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5949 if (declared
== NULL
)
5950 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5956 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5957 which of the specific bindings (if any) matches the arglist and transform
5958 the expression into a call of that binding. */
5961 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5963 gfc_typebound_proc
* genproc
;
5964 const char* genname
;
5966 gfc_symbol
*derived
;
5968 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5969 genname
= e
->value
.compcall
.name
;
5970 genproc
= e
->value
.compcall
.tbp
;
5972 if (!genproc
->is_generic
)
5975 /* Try the bindings on this type and in the inheritance hierarchy. */
5976 for (; genproc
; genproc
= genproc
->overridden
)
5980 gcc_assert (genproc
->is_generic
);
5981 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5984 gfc_actual_arglist
* args
;
5987 gcc_assert (g
->specific
);
5989 if (g
->specific
->error
)
5992 target
= g
->specific
->u
.specific
->n
.sym
;
5994 /* Get the right arglist by handling PASS/NOPASS. */
5995 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5996 if (!g
->specific
->nopass
)
5999 po
= extract_compcall_passed_object (e
);
6002 gfc_free_actual_arglist (args
);
6006 gcc_assert (g
->specific
->pass_arg_num
> 0);
6007 gcc_assert (!g
->specific
->error
);
6008 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6009 g
->specific
->pass_arg
);
6011 resolve_actual_arglist (args
, target
->attr
.proc
,
6012 is_external_proc (target
)
6013 && gfc_sym_get_dummy_args (target
) == NULL
);
6015 /* Check if this arglist matches the formal. */
6016 matches
= gfc_arglist_matches_symbol (&args
, target
);
6018 /* Clean up and break out of the loop if we've found it. */
6019 gfc_free_actual_arglist (args
);
6022 e
->value
.compcall
.tbp
= g
->specific
;
6023 genname
= g
->specific_st
->name
;
6024 /* Pass along the name for CLASS methods, where the vtab
6025 procedure pointer component has to be referenced. */
6033 /* Nothing matching found! */
6034 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6035 " '%s' at %L", genname
, &e
->where
);
6039 /* Make sure that we have the right specific instance for the name. */
6040 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6042 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6044 e
->value
.compcall
.tbp
= st
->n
.tb
;
6050 /* Resolve a call to a type-bound subroutine. */
6053 resolve_typebound_call (gfc_code
* c
, const char **name
)
6055 gfc_actual_arglist
* newactual
;
6056 gfc_symtree
* target
;
6058 /* Check that's really a SUBROUTINE. */
6059 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6061 gfc_error ("'%s' at %L should be a SUBROUTINE",
6062 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6066 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
6069 /* Pass along the name for CLASS methods, where the vtab
6070 procedure pointer component has to be referenced. */
6072 *name
= c
->expr1
->value
.compcall
.name
;
6074 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
6077 /* Transform into an ordinary EXEC_CALL for now. */
6079 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
6082 c
->ext
.actual
= newactual
;
6083 c
->symtree
= target
;
6084 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6086 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6088 gfc_free_expr (c
->expr1
);
6089 c
->expr1
= gfc_get_expr ();
6090 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6091 c
->expr1
->symtree
= target
;
6092 c
->expr1
->where
= c
->loc
;
6094 return resolve_call (c
);
6098 /* Resolve a component-call expression. */
6100 resolve_compcall (gfc_expr
* e
, const char **name
)
6102 gfc_actual_arglist
* newactual
;
6103 gfc_symtree
* target
;
6105 /* Check that's really a FUNCTION. */
6106 if (!e
->value
.compcall
.tbp
->function
)
6108 gfc_error ("'%s' at %L should be a FUNCTION",
6109 e
->value
.compcall
.name
, &e
->where
);
6113 /* These must not be assign-calls! */
6114 gcc_assert (!e
->value
.compcall
.assign
);
6116 if (check_typebound_baseobject (e
) == FAILURE
)
6119 /* Pass along the name for CLASS methods, where the vtab
6120 procedure pointer component has to be referenced. */
6122 *name
= e
->value
.compcall
.name
;
6124 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
6126 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6128 /* Take the rank from the function's symbol. */
6129 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6130 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6132 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6133 arglist to the TBP's binding target. */
6135 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
6138 e
->value
.function
.actual
= newactual
;
6139 e
->value
.function
.name
= NULL
;
6140 e
->value
.function
.esym
= target
->n
.sym
;
6141 e
->value
.function
.isym
= NULL
;
6142 e
->symtree
= target
;
6143 e
->ts
= target
->n
.sym
->ts
;
6144 e
->expr_type
= EXPR_FUNCTION
;
6146 /* Resolution is not necessary if this is a class subroutine; this
6147 function only has to identify the specific proc. Resolution of
6148 the call will be done next in resolve_typebound_call. */
6149 return gfc_resolve_expr (e
);
6154 /* Resolve a typebound function, or 'method'. First separate all
6155 the non-CLASS references by calling resolve_compcall directly. */
6158 resolve_typebound_function (gfc_expr
* e
)
6160 gfc_symbol
*declared
;
6172 /* Deal with typebound operators for CLASS objects. */
6173 expr
= e
->value
.compcall
.base_object
;
6174 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6175 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6177 /* If the base_object is not a variable, the corresponding actual
6178 argument expression must be stored in e->base_expression so
6179 that the corresponding tree temporary can be used as the base
6180 object in gfc_conv_procedure_call. */
6181 if (expr
->expr_type
!= EXPR_VARIABLE
)
6183 gfc_actual_arglist
*args
;
6185 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6187 if (expr
== args
->expr
)
6192 /* Since the typebound operators are generic, we have to ensure
6193 that any delays in resolution are corrected and that the vtab
6196 declared
= ts
.u
.derived
;
6197 c
= gfc_find_component (declared
, "_vptr", true, true);
6198 if (c
->ts
.u
.derived
== NULL
)
6199 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6201 if (resolve_compcall (e
, &name
) == FAILURE
)
6204 /* Use the generic name if it is there. */
6205 name
= name
? name
: e
->value
.function
.esym
->name
;
6206 e
->symtree
= expr
->symtree
;
6207 e
->ref
= gfc_copy_ref (expr
->ref
);
6208 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6210 /* Trim away the extraneous references that emerge from nested
6211 use of interface.c (extend_expr). */
6212 if (class_ref
&& class_ref
->next
)
6214 gfc_free_ref_list (class_ref
->next
);
6215 class_ref
->next
= NULL
;
6217 else if (e
->ref
&& !class_ref
)
6219 gfc_free_ref_list (e
->ref
);
6223 gfc_add_vptr_component (e
);
6224 gfc_add_component_ref (e
, name
);
6225 e
->value
.function
.esym
= NULL
;
6226 if (expr
->expr_type
!= EXPR_VARIABLE
)
6227 e
->base_expr
= expr
;
6232 return resolve_compcall (e
, NULL
);
6234 if (resolve_ref (e
) == FAILURE
)
6237 /* Get the CLASS declared type. */
6238 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6240 /* Weed out cases of the ultimate component being a derived type. */
6241 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6242 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6244 gfc_free_ref_list (new_ref
);
6245 return resolve_compcall (e
, NULL
);
6248 c
= gfc_find_component (declared
, "_data", true, true);
6249 declared
= c
->ts
.u
.derived
;
6251 /* Treat the call as if it is a typebound procedure, in order to roll
6252 out the correct name for the specific function. */
6253 if (resolve_compcall (e
, &name
) == FAILURE
)
6255 gfc_free_ref_list (new_ref
);
6262 /* Convert the expression to a procedure pointer component call. */
6263 e
->value
.function
.esym
= NULL
;
6269 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6270 gfc_add_vptr_component (e
);
6271 gfc_add_component_ref (e
, name
);
6273 /* Recover the typespec for the expression. This is really only
6274 necessary for generic procedures, where the additional call
6275 to gfc_add_component_ref seems to throw the collection of the
6276 correct typespec. */
6283 /* Resolve a typebound subroutine, or 'method'. First separate all
6284 the non-CLASS references by calling resolve_typebound_call
6288 resolve_typebound_subroutine (gfc_code
*code
)
6290 gfc_symbol
*declared
;
6300 st
= code
->expr1
->symtree
;
6302 /* Deal with typebound operators for CLASS objects. */
6303 expr
= code
->expr1
->value
.compcall
.base_object
;
6304 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6305 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6307 /* If the base_object is not a variable, the corresponding actual
6308 argument expression must be stored in e->base_expression so
6309 that the corresponding tree temporary can be used as the base
6310 object in gfc_conv_procedure_call. */
6311 if (expr
->expr_type
!= EXPR_VARIABLE
)
6313 gfc_actual_arglist
*args
;
6315 args
= code
->expr1
->value
.function
.actual
;
6316 for (; args
; args
= args
->next
)
6317 if (expr
== args
->expr
)
6321 /* Since the typebound operators are generic, we have to ensure
6322 that any delays in resolution are corrected and that the vtab
6324 declared
= expr
->ts
.u
.derived
;
6325 c
= gfc_find_component (declared
, "_vptr", true, true);
6326 if (c
->ts
.u
.derived
== NULL
)
6327 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6329 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6332 /* Use the generic name if it is there. */
6333 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6334 code
->expr1
->symtree
= expr
->symtree
;
6335 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6337 /* Trim away the extraneous references that emerge from nested
6338 use of interface.c (extend_expr). */
6339 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6340 if (class_ref
&& class_ref
->next
)
6342 gfc_free_ref_list (class_ref
->next
);
6343 class_ref
->next
= NULL
;
6345 else if (code
->expr1
->ref
&& !class_ref
)
6347 gfc_free_ref_list (code
->expr1
->ref
);
6348 code
->expr1
->ref
= NULL
;
6351 /* Now use the procedure in the vtable. */
6352 gfc_add_vptr_component (code
->expr1
);
6353 gfc_add_component_ref (code
->expr1
, name
);
6354 code
->expr1
->value
.function
.esym
= NULL
;
6355 if (expr
->expr_type
!= EXPR_VARIABLE
)
6356 code
->expr1
->base_expr
= expr
;
6361 return resolve_typebound_call (code
, NULL
);
6363 if (resolve_ref (code
->expr1
) == FAILURE
)
6366 /* Get the CLASS declared type. */
6367 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6369 /* Weed out cases of the ultimate component being a derived type. */
6370 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6371 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6373 gfc_free_ref_list (new_ref
);
6374 return resolve_typebound_call (code
, NULL
);
6377 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6379 gfc_free_ref_list (new_ref
);
6382 ts
= code
->expr1
->ts
;
6386 /* Convert the expression to a procedure pointer component call. */
6387 code
->expr1
->value
.function
.esym
= NULL
;
6388 code
->expr1
->symtree
= st
;
6391 code
->expr1
->ref
= new_ref
;
6393 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6394 gfc_add_vptr_component (code
->expr1
);
6395 gfc_add_component_ref (code
->expr1
, name
);
6397 /* Recover the typespec for the expression. This is really only
6398 necessary for generic procedures, where the additional call
6399 to gfc_add_component_ref seems to throw the collection of the
6400 correct typespec. */
6401 code
->expr1
->ts
= ts
;
6408 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6411 resolve_ppc_call (gfc_code
* c
)
6413 gfc_component
*comp
;
6415 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6416 gcc_assert (comp
!= NULL
);
6418 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6419 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6421 if (!comp
->attr
.subroutine
)
6422 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6424 if (resolve_ref (c
->expr1
) == FAILURE
)
6427 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6430 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6432 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6433 !(comp
->ts
.interface
&& comp
->ts
.interface
->formal
)) == FAILURE
)
6436 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6442 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6445 resolve_expr_ppc (gfc_expr
* e
)
6447 gfc_component
*comp
;
6449 comp
= gfc_get_proc_ptr_comp (e
);
6450 gcc_assert (comp
!= NULL
);
6452 /* Convert to EXPR_FUNCTION. */
6453 e
->expr_type
= EXPR_FUNCTION
;
6454 e
->value
.function
.isym
= NULL
;
6455 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6457 if (comp
->as
!= NULL
)
6458 e
->rank
= comp
->as
->rank
;
6460 if (!comp
->attr
.function
)
6461 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6463 if (resolve_ref (e
) == FAILURE
)
6466 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6467 !(comp
->ts
.interface
&& comp
->ts
.interface
->formal
)) == FAILURE
)
6470 if (update_ppc_arglist (e
) == FAILURE
)
6473 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6480 gfc_is_expandable_expr (gfc_expr
*e
)
6482 gfc_constructor
*con
;
6484 if (e
->expr_type
== EXPR_ARRAY
)
6486 /* Traverse the constructor looking for variables that are flavor
6487 parameter. Parameters must be expanded since they are fully used at
6489 con
= gfc_constructor_first (e
->value
.constructor
);
6490 for (; con
; con
= gfc_constructor_next (con
))
6492 if (con
->expr
->expr_type
== EXPR_VARIABLE
6493 && con
->expr
->symtree
6494 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6495 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6497 if (con
->expr
->expr_type
== EXPR_ARRAY
6498 && gfc_is_expandable_expr (con
->expr
))
6506 /* Resolve an expression. That is, make sure that types of operands agree
6507 with their operators, intrinsic operators are converted to function calls
6508 for overloaded types and unresolved function references are resolved. */
6511 gfc_resolve_expr (gfc_expr
*e
)
6514 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6519 /* inquiry_argument only applies to variables. */
6520 inquiry_save
= inquiry_argument
;
6521 actual_arg_save
= actual_arg
;
6522 first_actual_arg_save
= first_actual_arg
;
6524 if (e
->expr_type
!= EXPR_VARIABLE
)
6526 inquiry_argument
= false;
6528 first_actual_arg
= false;
6531 switch (e
->expr_type
)
6534 t
= resolve_operator (e
);
6540 if (check_host_association (e
))
6541 t
= resolve_function (e
);
6544 t
= resolve_variable (e
);
6546 expression_rank (e
);
6549 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6550 && e
->ref
->type
!= REF_SUBSTRING
)
6551 gfc_resolve_substring_charlen (e
);
6556 t
= resolve_typebound_function (e
);
6559 case EXPR_SUBSTRING
:
6560 t
= resolve_ref (e
);
6569 t
= resolve_expr_ppc (e
);
6574 if (resolve_ref (e
) == FAILURE
)
6577 t
= gfc_resolve_array_constructor (e
);
6578 /* Also try to expand a constructor. */
6581 expression_rank (e
);
6582 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6583 gfc_expand_constructor (e
, false);
6586 /* This provides the opportunity for the length of constructors with
6587 character valued function elements to propagate the string length
6588 to the expression. */
6589 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6591 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6592 here rather then add a duplicate test for it above. */
6593 gfc_expand_constructor (e
, false);
6594 t
= gfc_resolve_character_array_constructor (e
);
6599 case EXPR_STRUCTURE
:
6600 t
= resolve_ref (e
);
6604 t
= resolve_structure_cons (e
, 0);
6608 t
= gfc_simplify_expr (e
, 0);
6612 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6615 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6618 inquiry_argument
= inquiry_save
;
6619 actual_arg
= actual_arg_save
;
6620 first_actual_arg
= first_actual_arg_save
;
6626 /* Resolve an expression from an iterator. They must be scalar and have
6627 INTEGER or (optionally) REAL type. */
6630 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6631 const char *name_msgid
)
6633 if (gfc_resolve_expr (expr
) == FAILURE
)
6636 if (expr
->rank
!= 0)
6638 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6642 if (expr
->ts
.type
!= BT_INTEGER
)
6644 if (expr
->ts
.type
== BT_REAL
)
6647 return gfc_notify_std (GFC_STD_F95_DEL
,
6648 "%s at %L must be integer",
6649 _(name_msgid
), &expr
->where
);
6652 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6659 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6667 /* Resolve the expressions in an iterator structure. If REAL_OK is
6668 false allow only INTEGER type iterators, otherwise allow REAL types.
6669 Set own_scope to true for ac-implied-do and data-implied-do as those
6670 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6673 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6675 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6679 if (gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6680 _("iterator variable"))
6684 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6685 "Start expression in DO loop") == FAILURE
)
6688 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6689 "End expression in DO loop") == FAILURE
)
6692 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6693 "Step expression in DO loop") == FAILURE
)
6696 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6698 if ((iter
->step
->ts
.type
== BT_INTEGER
6699 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6700 || (iter
->step
->ts
.type
== BT_REAL
6701 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6703 gfc_error ("Step expression in DO loop at %L cannot be zero",
6704 &iter
->step
->where
);
6709 /* Convert start, end, and step to the same type as var. */
6710 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6711 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6712 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6714 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6715 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6716 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6718 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6719 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6720 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6722 if (iter
->start
->expr_type
== EXPR_CONSTANT
6723 && iter
->end
->expr_type
== EXPR_CONSTANT
6724 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6727 if (iter
->start
->ts
.type
== BT_INTEGER
)
6729 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6730 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6734 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6735 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6737 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6738 gfc_warning ("DO loop at %L will be executed zero times",
6739 &iter
->step
->where
);
6746 /* Traversal function for find_forall_index. f == 2 signals that
6747 that variable itself is not to be checked - only the references. */
6750 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6752 if (expr
->expr_type
!= EXPR_VARIABLE
)
6755 /* A scalar assignment */
6756 if (!expr
->ref
|| *f
== 1)
6758 if (expr
->symtree
->n
.sym
== sym
)
6770 /* Check whether the FORALL index appears in the expression or not.
6771 Returns SUCCESS if SYM is found in EXPR. */
6774 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6776 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6783 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6784 to be a scalar INTEGER variable. The subscripts and stride are scalar
6785 INTEGERs, and if stride is a constant it must be nonzero.
6786 Furthermore "A subscript or stride in a forall-triplet-spec shall
6787 not contain a reference to any index-name in the
6788 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6791 resolve_forall_iterators (gfc_forall_iterator
*it
)
6793 gfc_forall_iterator
*iter
, *iter2
;
6795 for (iter
= it
; iter
; iter
= iter
->next
)
6797 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6798 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6799 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6802 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6803 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6804 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6805 &iter
->start
->where
);
6806 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6807 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6809 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6810 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6811 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6813 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6814 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6816 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6818 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6819 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6820 &iter
->stride
->where
, "INTEGER");
6822 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6823 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6824 gfc_error ("FORALL stride expression at %L cannot be zero",
6825 &iter
->stride
->where
);
6827 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6828 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6831 for (iter
= it
; iter
; iter
= iter
->next
)
6832 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6834 if (find_forall_index (iter2
->start
,
6835 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6836 || find_forall_index (iter2
->end
,
6837 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6838 || find_forall_index (iter2
->stride
,
6839 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6840 gfc_error ("FORALL index '%s' may not appear in triplet "
6841 "specification at %L", iter
->var
->symtree
->name
,
6842 &iter2
->start
->where
);
6847 /* Given a pointer to a symbol that is a derived type, see if it's
6848 inaccessible, i.e. if it's defined in another module and the components are
6849 PRIVATE. The search is recursive if necessary. Returns zero if no
6850 inaccessible components are found, nonzero otherwise. */
6853 derived_inaccessible (gfc_symbol
*sym
)
6857 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6860 for (c
= sym
->components
; c
; c
= c
->next
)
6862 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6870 /* Resolve the argument of a deallocate expression. The expression must be
6871 a pointer or a full array. */
6874 resolve_deallocate_expr (gfc_expr
*e
)
6876 symbol_attribute attr
;
6877 int allocatable
, pointer
;
6883 if (gfc_resolve_expr (e
) == FAILURE
)
6886 if (e
->expr_type
!= EXPR_VARIABLE
)
6889 sym
= e
->symtree
->n
.sym
;
6890 unlimited
= UNLIMITED_POLY(sym
);
6892 if (sym
->ts
.type
== BT_CLASS
)
6894 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6895 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6899 allocatable
= sym
->attr
.allocatable
;
6900 pointer
= sym
->attr
.pointer
;
6902 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6907 if (ref
->u
.ar
.type
!= AR_FULL
6908 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6909 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6914 c
= ref
->u
.c
.component
;
6915 if (c
->ts
.type
== BT_CLASS
)
6917 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6918 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6922 allocatable
= c
->attr
.allocatable
;
6923 pointer
= c
->attr
.pointer
;
6933 attr
= gfc_expr_attr (e
);
6935 if (allocatable
== 0 && attr
.pointer
== 0 && !unlimited
)
6938 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6944 if (gfc_is_coindexed (e
))
6946 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6951 && gfc_check_vardef_context (e
, true, true, false, _("DEALLOCATE object"))
6954 if (gfc_check_vardef_context (e
, false, true, false, _("DEALLOCATE object"))
6962 /* Returns true if the expression e contains a reference to the symbol sym. */
6964 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6966 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6973 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6975 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6979 /* Given the expression node e for an allocatable/pointer of derived type to be
6980 allocated, get the expression node to be initialized afterwards (needed for
6981 derived types with default initializers, and derived types with allocatable
6982 components that need nullification.) */
6985 gfc_expr_to_initialize (gfc_expr
*e
)
6991 result
= gfc_copy_expr (e
);
6993 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6994 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6995 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6997 ref
->u
.ar
.type
= AR_FULL
;
6999 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7000 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7005 gfc_free_shape (&result
->shape
, result
->rank
);
7007 /* Recalculate rank, shape, etc. */
7008 gfc_resolve_expr (result
);
7013 /* If the last ref of an expression is an array ref, return a copy of the
7014 expression with that one removed. Otherwise, a copy of the original
7015 expression. This is used for allocate-expressions and pointer assignment
7016 LHS, where there may be an array specification that needs to be stripped
7017 off when using gfc_check_vardef_context. */
7020 remove_last_array_ref (gfc_expr
* e
)
7025 e2
= gfc_copy_expr (e
);
7026 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7027 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7029 gfc_free_ref_list (*r
);
7038 /* Used in resolve_allocate_expr to check that a allocation-object and
7039 a source-expr are conformable. This does not catch all possible
7040 cases; in particular a runtime checking is needed. */
7043 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7046 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7048 /* First compare rank. */
7049 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7051 gfc_error ("Source-expr at %L must be scalar or have the "
7052 "same rank as the allocate-object at %L",
7053 &e1
->where
, &e2
->where
);
7064 for (i
= 0; i
< e1
->rank
; i
++)
7066 if (tail
->u
.ar
.end
[i
])
7068 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7069 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7070 mpz_add_ui (s
, s
, 1);
7074 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7077 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7079 gfc_error ("Source-expr at %L and allocate-object at %L must "
7080 "have the same shape", &e1
->where
, &e2
->where
);
7093 /* Resolve the expression in an ALLOCATE statement, doing the additional
7094 checks to see whether the expression is OK or not. The expression must
7095 have a trailing array reference that gives the size of the array. */
7098 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
7100 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7104 symbol_attribute attr
;
7105 gfc_ref
*ref
, *ref2
;
7108 gfc_symbol
*sym
= NULL
;
7113 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7114 checking of coarrays. */
7115 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7116 if (ref
->next
== NULL
)
7119 if (ref
&& ref
->type
== REF_ARRAY
)
7120 ref
->u
.ar
.in_allocate
= true;
7122 if (gfc_resolve_expr (e
) == FAILURE
)
7125 /* Make sure the expression is allocatable or a pointer. If it is
7126 pointer, the next-to-last reference must be a pointer. */
7130 sym
= e
->symtree
->n
.sym
;
7132 /* Check whether ultimate component is abstract and CLASS. */
7135 /* Is the allocate-object unlimited polymorphic? */
7136 unlimited
= UNLIMITED_POLY(e
);
7138 if (e
->expr_type
!= EXPR_VARIABLE
)
7141 attr
= gfc_expr_attr (e
);
7142 pointer
= attr
.pointer
;
7143 dimension
= attr
.dimension
;
7144 codimension
= attr
.codimension
;
7148 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7150 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7151 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7152 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7153 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7154 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7158 allocatable
= sym
->attr
.allocatable
;
7159 pointer
= sym
->attr
.pointer
;
7160 dimension
= sym
->attr
.dimension
;
7161 codimension
= sym
->attr
.codimension
;
7166 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7171 if (ref
->u
.ar
.codimen
> 0)
7174 for (n
= ref
->u
.ar
.dimen
;
7175 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7176 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7183 if (ref
->next
!= NULL
)
7191 gfc_error ("Coindexed allocatable object at %L",
7196 c
= ref
->u
.c
.component
;
7197 if (c
->ts
.type
== BT_CLASS
)
7199 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7200 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7201 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7202 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7203 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7207 allocatable
= c
->attr
.allocatable
;
7208 pointer
= c
->attr
.pointer
;
7209 dimension
= c
->attr
.dimension
;
7210 codimension
= c
->attr
.codimension
;
7211 is_abstract
= c
->attr
.abstract
;
7223 /* Check for F08:C628. */
7224 if (allocatable
== 0 && pointer
== 0 && !unlimited
)
7226 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7231 /* Some checks for the SOURCE tag. */
7234 /* Check F03:C631. */
7235 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7237 gfc_error ("Type of entity at %L is type incompatible with "
7238 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7242 /* Check F03:C632 and restriction following Note 6.18. */
7243 if (code
->expr3
->rank
> 0 && !unlimited
7244 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
7247 /* Check F03:C633. */
7248 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
&& !unlimited
)
7250 gfc_error ("The allocate-object at %L and the source-expr at %L "
7251 "shall have the same kind type parameter",
7252 &e
->where
, &code
->expr3
->where
);
7256 /* Check F2008, C642. */
7257 if (code
->expr3
->ts
.type
== BT_DERIVED
7258 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7259 || (code
->expr3
->ts
.u
.derived
->from_intmod
7260 == INTMOD_ISO_FORTRAN_ENV
7261 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7262 == ISOFORTRAN_LOCK_TYPE
)))
7264 gfc_error ("The source-expr at %L shall neither be of type "
7265 "LOCK_TYPE nor have a LOCK_TYPE component if "
7266 "allocate-object at %L is a coarray",
7267 &code
->expr3
->where
, &e
->where
);
7272 /* Check F08:C629. */
7273 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7276 gcc_assert (e
->ts
.type
== BT_CLASS
);
7277 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7278 "type-spec or source-expr", sym
->name
, &e
->where
);
7282 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
7284 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7285 code
->ext
.alloc
.ts
.u
.cl
->length
);
7286 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7288 gfc_error ("Allocating %s at %L with type-spec requires the same "
7289 "character-length parameter as in the declaration",
7290 sym
->name
, &e
->where
);
7295 /* In the variable definition context checks, gfc_expr_attr is used
7296 on the expression. This is fooled by the array specification
7297 present in e, thus we have to eliminate that one temporarily. */
7298 e2
= remove_last_array_ref (e
);
7300 if (t
== SUCCESS
&& pointer
)
7301 t
= gfc_check_vardef_context (e2
, true, true, false, _("ALLOCATE object"));
7303 t
= gfc_check_vardef_context (e2
, false, true, false, _("ALLOCATE object"));
7308 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7309 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7311 /* For class arrays, the initialization with SOURCE is done
7312 using _copy and trans_call. It is convenient to exploit that
7313 when the allocated type is different from the declared type but
7314 no SOURCE exists by setting expr3. */
7315 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7317 else if (!code
->expr3
)
7319 /* Set up default initializer if needed. */
7323 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7324 ts
= code
->ext
.alloc
.ts
;
7328 if (ts
.type
== BT_CLASS
)
7329 ts
= ts
.u
.derived
->components
->ts
;
7331 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7333 gfc_code
*init_st
= gfc_get_code ();
7334 init_st
->loc
= code
->loc
;
7335 init_st
->op
= EXEC_INIT_ASSIGN
;
7336 init_st
->expr1
= gfc_expr_to_initialize (e
);
7337 init_st
->expr2
= init_e
;
7338 init_st
->next
= code
->next
;
7339 code
->next
= init_st
;
7342 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7344 /* Default initialization via MOLD (non-polymorphic). */
7345 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7346 gfc_resolve_expr (rhs
);
7347 gfc_free_expr (code
->expr3
);
7351 if (e
->ts
.type
== BT_CLASS
&& !unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7353 /* Make sure the vtab symbol is present when
7354 the module variables are generated. */
7355 gfc_typespec ts
= e
->ts
;
7357 ts
= code
->expr3
->ts
;
7358 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7359 ts
= code
->ext
.alloc
.ts
;
7361 gfc_find_derived_vtab (ts
.u
.derived
);
7364 e
= gfc_expr_to_initialize (e
);
7366 else if (unlimited
&& !UNLIMITED_POLY (code
->expr3
))
7368 /* Again, make sure the vtab symbol is present when
7369 the module variables are generated. */
7370 gfc_typespec
*ts
= NULL
;
7372 ts
= &code
->expr3
->ts
;
7374 ts
= &code
->ext
.alloc
.ts
;
7378 if (ts
->type
== BT_CLASS
|| ts
->type
== BT_DERIVED
)
7379 gfc_find_derived_vtab (ts
->u
.derived
);
7381 gfc_find_intrinsic_vtab (ts
);
7384 e
= gfc_expr_to_initialize (e
);
7387 if (dimension
== 0 && codimension
== 0)
7390 /* Make sure the last reference node is an array specification. */
7392 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7393 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7395 gfc_error ("Array specification required in ALLOCATE statement "
7396 "at %L", &e
->where
);
7400 /* Make sure that the array section reference makes sense in the
7401 context of an ALLOCATE specification. */
7406 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7407 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7409 gfc_error ("Coarray specification required in ALLOCATE statement "
7410 "at %L", &e
->where
);
7414 for (i
= 0; i
< ar
->dimen
; i
++)
7416 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7419 switch (ar
->dimen_type
[i
])
7425 if (ar
->start
[i
] != NULL
7426 && ar
->end
[i
] != NULL
7427 && ar
->stride
[i
] == NULL
)
7430 /* Fall Through... */
7435 case DIMEN_THIS_IMAGE
:
7436 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7442 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7444 sym
= a
->expr
->symtree
->n
.sym
;
7446 /* TODO - check derived type components. */
7447 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7450 if ((ar
->start
[i
] != NULL
7451 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7452 || (ar
->end
[i
] != NULL
7453 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7455 gfc_error ("'%s' must not appear in the array specification at "
7456 "%L in the same ALLOCATE statement where it is "
7457 "itself allocated", sym
->name
, &ar
->where
);
7463 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7465 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7466 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7468 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7470 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7471 "statement at %L", &e
->where
);
7477 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7478 && ar
->stride
[i
] == NULL
)
7481 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7494 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7496 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7497 gfc_alloc
*a
, *p
, *q
;
7500 errmsg
= code
->expr2
;
7502 /* Check the stat variable. */
7505 gfc_check_vardef_context (stat
, false, false, false, _("STAT variable"));
7507 if ((stat
->ts
.type
!= BT_INTEGER
7508 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7509 || stat
->ref
->type
== REF_COMPONENT
)))
7511 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7512 "variable", &stat
->where
);
7514 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7515 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7517 gfc_ref
*ref1
, *ref2
;
7520 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7521 ref1
= ref1
->next
, ref2
= ref2
->next
)
7523 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7525 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7534 gfc_error ("Stat-variable at %L shall not be %sd within "
7535 "the same %s statement", &stat
->where
, fcn
, fcn
);
7541 /* Check the errmsg variable. */
7545 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7548 gfc_check_vardef_context (errmsg
, false, false, false,
7549 _("ERRMSG variable"));
7551 if ((errmsg
->ts
.type
!= BT_CHARACTER
7553 && (errmsg
->ref
->type
== REF_ARRAY
7554 || errmsg
->ref
->type
== REF_COMPONENT
)))
7555 || errmsg
->rank
> 0 )
7556 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7557 "variable", &errmsg
->where
);
7559 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7560 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7562 gfc_ref
*ref1
, *ref2
;
7565 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7566 ref1
= ref1
->next
, ref2
= ref2
->next
)
7568 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7570 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7579 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7580 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7586 /* Check that an allocate-object appears only once in the statement. */
7588 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7591 for (q
= p
->next
; q
; q
= q
->next
)
7594 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7596 /* This is a potential collision. */
7597 gfc_ref
*pr
= pe
->ref
;
7598 gfc_ref
*qr
= qe
->ref
;
7600 /* Follow the references until
7601 a) They start to differ, in which case there is no error;
7602 you can deallocate a%b and a%c in a single statement
7603 b) Both of them stop, which is an error
7604 c) One of them stops, which is also an error. */
7607 if (pr
== NULL
&& qr
== NULL
)
7609 gfc_error ("Allocate-object at %L also appears at %L",
7610 &pe
->where
, &qe
->where
);
7613 else if (pr
!= NULL
&& qr
== NULL
)
7615 gfc_error ("Allocate-object at %L is subobject of"
7616 " object at %L", &pe
->where
, &qe
->where
);
7619 else if (pr
== NULL
&& qr
!= NULL
)
7621 gfc_error ("Allocate-object at %L is subobject of"
7622 " object at %L", &qe
->where
, &pe
->where
);
7625 /* Here, pr != NULL && qr != NULL */
7626 gcc_assert(pr
->type
== qr
->type
);
7627 if (pr
->type
== REF_ARRAY
)
7629 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7631 gcc_assert (qr
->type
== REF_ARRAY
);
7633 if (pr
->next
&& qr
->next
)
7636 gfc_array_ref
*par
= &(pr
->u
.ar
);
7637 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7639 for (i
=0; i
<par
->dimen
; i
++)
7641 if ((par
->start
[i
] != NULL
7642 || qar
->start
[i
] != NULL
)
7643 && gfc_dep_compare_expr (par
->start
[i
],
7644 qar
->start
[i
]) != 0)
7651 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7664 if (strcmp (fcn
, "ALLOCATE") == 0)
7666 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7667 resolve_allocate_expr (a
->expr
, code
);
7671 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7672 resolve_deallocate_expr (a
->expr
);
7677 /************ SELECT CASE resolution subroutines ************/
7679 /* Callback function for our mergesort variant. Determines interval
7680 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7681 op1 > op2. Assumes we're not dealing with the default case.
7682 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7683 There are nine situations to check. */
7686 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7690 if (op1
->low
== NULL
) /* op1 = (:L) */
7692 /* op2 = (:N), so overlap. */
7694 /* op2 = (M:) or (M:N), L < M */
7695 if (op2
->low
!= NULL
7696 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7699 else if (op1
->high
== NULL
) /* op1 = (K:) */
7701 /* op2 = (M:), so overlap. */
7703 /* op2 = (:N) or (M:N), K > N */
7704 if (op2
->high
!= NULL
7705 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7708 else /* op1 = (K:L) */
7710 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7711 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7713 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7714 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7716 else /* op2 = (M:N) */
7720 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7723 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7732 /* Merge-sort a double linked case list, detecting overlap in the
7733 process. LIST is the head of the double linked case list before it
7734 is sorted. Returns the head of the sorted list if we don't see any
7735 overlap, or NULL otherwise. */
7738 check_case_overlap (gfc_case
*list
)
7740 gfc_case
*p
, *q
, *e
, *tail
;
7741 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7743 /* If the passed list was empty, return immediately. */
7750 /* Loop unconditionally. The only exit from this loop is a return
7751 statement, when we've finished sorting the case list. */
7758 /* Count the number of merges we do in this pass. */
7761 /* Loop while there exists a merge to be done. */
7766 /* Count this merge. */
7769 /* Cut the list in two pieces by stepping INSIZE places
7770 forward in the list, starting from P. */
7773 for (i
= 0; i
< insize
; i
++)
7782 /* Now we have two lists. Merge them! */
7783 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7785 /* See from which the next case to merge comes from. */
7788 /* P is empty so the next case must come from Q. */
7793 else if (qsize
== 0 || q
== NULL
)
7802 cmp
= compare_cases (p
, q
);
7805 /* The whole case range for P is less than the
7813 /* The whole case range for Q is greater than
7814 the case range for P. */
7821 /* The cases overlap, or they are the same
7822 element in the list. Either way, we must
7823 issue an error and get the next case from P. */
7824 /* FIXME: Sort P and Q by line number. */
7825 gfc_error ("CASE label at %L overlaps with CASE "
7826 "label at %L", &p
->where
, &q
->where
);
7834 /* Add the next element to the merged list. */
7843 /* P has now stepped INSIZE places along, and so has Q. So
7844 they're the same. */
7849 /* If we have done only one merge or none at all, we've
7850 finished sorting the cases. */
7859 /* Otherwise repeat, merging lists twice the size. */
7865 /* Check to see if an expression is suitable for use in a CASE statement.
7866 Makes sure that all case expressions are scalar constants of the same
7867 type. Return FAILURE if anything is wrong. */
7870 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7872 if (e
== NULL
) return SUCCESS
;
7874 if (e
->ts
.type
!= case_expr
->ts
.type
)
7876 gfc_error ("Expression in CASE statement at %L must be of type %s",
7877 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7881 /* C805 (R808) For a given case-construct, each case-value shall be of
7882 the same type as case-expr. For character type, length differences
7883 are allowed, but the kind type parameters shall be the same. */
7885 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7887 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7888 &e
->where
, case_expr
->ts
.kind
);
7892 /* Convert the case value kind to that of case expression kind,
7895 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7896 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7900 gfc_error ("Expression in CASE statement at %L must be scalar",
7909 /* Given a completely parsed select statement, we:
7911 - Validate all expressions and code within the SELECT.
7912 - Make sure that the selection expression is not of the wrong type.
7913 - Make sure that no case ranges overlap.
7914 - Eliminate unreachable cases and unreachable code resulting from
7915 removing case labels.
7917 The standard does allow unreachable cases, e.g. CASE (5:3). But
7918 they are a hassle for code generation, and to prevent that, we just
7919 cut them out here. This is not necessary for overlapping cases
7920 because they are illegal and we never even try to generate code.
7922 We have the additional caveat that a SELECT construct could have
7923 been a computed GOTO in the source code. Fortunately we can fairly
7924 easily work around that here: The case_expr for a "real" SELECT CASE
7925 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7926 we have to do is make sure that the case_expr is a scalar integer
7930 resolve_select (gfc_code
*code
, bool select_type
)
7933 gfc_expr
*case_expr
;
7934 gfc_case
*cp
, *default_case
, *tail
, *head
;
7935 int seen_unreachable
;
7941 if (code
->expr1
== NULL
)
7943 /* This was actually a computed GOTO statement. */
7944 case_expr
= code
->expr2
;
7945 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7946 gfc_error ("Selection expression in computed GOTO statement "
7947 "at %L must be a scalar integer expression",
7950 /* Further checking is not necessary because this SELECT was built
7951 by the compiler, so it should always be OK. Just move the
7952 case_expr from expr2 to expr so that we can handle computed
7953 GOTOs as normal SELECTs from here on. */
7954 code
->expr1
= code
->expr2
;
7959 case_expr
= code
->expr1
;
7960 type
= case_expr
->ts
.type
;
7963 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7965 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7966 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7968 /* Punt. Going on here just produce more garbage error messages. */
7973 if (!select_type
&& case_expr
->rank
!= 0)
7975 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7976 "expression", &case_expr
->where
);
7982 /* Raise a warning if an INTEGER case value exceeds the range of
7983 the case-expr. Later, all expressions will be promoted to the
7984 largest kind of all case-labels. */
7986 if (type
== BT_INTEGER
)
7987 for (body
= code
->block
; body
; body
= body
->block
)
7988 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7991 && gfc_check_integer_range (cp
->low
->value
.integer
,
7992 case_expr
->ts
.kind
) != ARITH_OK
)
7993 gfc_warning ("Expression in CASE statement at %L is "
7994 "not in the range of %s", &cp
->low
->where
,
7995 gfc_typename (&case_expr
->ts
));
7998 && cp
->low
!= cp
->high
7999 && gfc_check_integer_range (cp
->high
->value
.integer
,
8000 case_expr
->ts
.kind
) != ARITH_OK
)
8001 gfc_warning ("Expression in CASE statement at %L is "
8002 "not in the range of %s", &cp
->high
->where
,
8003 gfc_typename (&case_expr
->ts
));
8006 /* PR 19168 has a long discussion concerning a mismatch of the kinds
8007 of the SELECT CASE expression and its CASE values. Walk the lists
8008 of case values, and if we find a mismatch, promote case_expr to
8009 the appropriate kind. */
8011 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
8013 for (body
= code
->block
; body
; body
= body
->block
)
8015 /* Walk the case label list. */
8016 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8018 /* Intercept the DEFAULT case. It does not have a kind. */
8019 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8022 /* Unreachable case ranges are discarded, so ignore. */
8023 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8024 && cp
->low
!= cp
->high
8025 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8029 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8030 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8032 if (cp
->high
!= NULL
8033 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8034 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8039 /* Assume there is no DEFAULT case. */
8040 default_case
= NULL
;
8045 for (body
= code
->block
; body
; body
= body
->block
)
8047 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8049 seen_unreachable
= 0;
8051 /* Walk the case label list, making sure that all case labels
8053 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8055 /* Count the number of cases in the whole construct. */
8058 /* Intercept the DEFAULT case. */
8059 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8061 if (default_case
!= NULL
)
8063 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8064 "by a second DEFAULT CASE at %L",
8065 &default_case
->where
, &cp
->where
);
8076 /* Deal with single value cases and case ranges. Errors are
8077 issued from the validation function. */
8078 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
8079 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
8085 if (type
== BT_LOGICAL
8086 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8087 || cp
->low
!= cp
->high
))
8089 gfc_error ("Logical range in CASE statement at %L is not "
8090 "allowed", &cp
->low
->where
);
8095 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8098 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8099 if (value
& seen_logical
)
8101 gfc_error ("Constant logical value in CASE statement "
8102 "is repeated at %L",
8107 seen_logical
|= value
;
8110 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8111 && cp
->low
!= cp
->high
8112 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8114 if (gfc_option
.warn_surprising
)
8115 gfc_warning ("Range specification at %L can never "
8116 "be matched", &cp
->where
);
8118 cp
->unreachable
= 1;
8119 seen_unreachable
= 1;
8123 /* If the case range can be matched, it can also overlap with
8124 other cases. To make sure it does not, we put it in a
8125 double linked list here. We sort that with a merge sort
8126 later on to detect any overlapping cases. */
8130 head
->right
= head
->left
= NULL
;
8135 tail
->right
->left
= tail
;
8142 /* It there was a failure in the previous case label, give up
8143 for this case label list. Continue with the next block. */
8147 /* See if any case labels that are unreachable have been seen.
8148 If so, we eliminate them. This is a bit of a kludge because
8149 the case lists for a single case statement (label) is a
8150 single forward linked lists. */
8151 if (seen_unreachable
)
8153 /* Advance until the first case in the list is reachable. */
8154 while (body
->ext
.block
.case_list
!= NULL
8155 && body
->ext
.block
.case_list
->unreachable
)
8157 gfc_case
*n
= body
->ext
.block
.case_list
;
8158 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8160 gfc_free_case_list (n
);
8163 /* Strip all other unreachable cases. */
8164 if (body
->ext
.block
.case_list
)
8166 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
8168 if (cp
->next
->unreachable
)
8170 gfc_case
*n
= cp
->next
;
8171 cp
->next
= cp
->next
->next
;
8173 gfc_free_case_list (n
);
8180 /* See if there were overlapping cases. If the check returns NULL,
8181 there was overlap. In that case we don't do anything. If head
8182 is non-NULL, we prepend the DEFAULT case. The sorted list can
8183 then used during code generation for SELECT CASE constructs with
8184 a case expression of a CHARACTER type. */
8187 head
= check_case_overlap (head
);
8189 /* Prepend the default_case if it is there. */
8190 if (head
!= NULL
&& default_case
)
8192 default_case
->left
= NULL
;
8193 default_case
->right
= head
;
8194 head
->left
= default_case
;
8198 /* Eliminate dead blocks that may be the result if we've seen
8199 unreachable case labels for a block. */
8200 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8202 if (body
->block
->ext
.block
.case_list
== NULL
)
8204 /* Cut the unreachable block from the code chain. */
8205 gfc_code
*c
= body
->block
;
8206 body
->block
= c
->block
;
8208 /* Kill the dead block, but not the blocks below it. */
8210 gfc_free_statements (c
);
8214 /* More than two cases is legal but insane for logical selects.
8215 Issue a warning for it. */
8216 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
8218 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
8223 /* Check if a derived type is extensible. */
8226 gfc_type_is_extensible (gfc_symbol
*sym
)
8228 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
8229 || (sym
->attr
.is_class
8230 && sym
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
));
8234 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8235 correct as well as possibly the array-spec. */
8238 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8242 gcc_assert (sym
->assoc
);
8243 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8245 /* If this is for SELECT TYPE, the target may not yet be set. In that
8246 case, return. Resolution will be called later manually again when
8248 target
= sym
->assoc
->target
;
8251 gcc_assert (!sym
->assoc
->dangling
);
8253 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
8256 /* For variable targets, we get some attributes from the target. */
8257 if (target
->expr_type
== EXPR_VARIABLE
)
8261 gcc_assert (target
->symtree
);
8262 tsym
= target
->symtree
->n
.sym
;
8264 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8265 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8267 sym
->attr
.target
= tsym
->attr
.target
8268 || gfc_expr_attr (target
).pointer
;
8271 /* Get type if this was not already set. Note that it can be
8272 some other type than the target in case this is a SELECT TYPE
8273 selector! So we must not update when the type is already there. */
8274 if (sym
->ts
.type
== BT_UNKNOWN
)
8275 sym
->ts
= target
->ts
;
8276 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8278 /* See if this is a valid association-to-variable. */
8279 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8280 && !gfc_has_vector_subscript (target
));
8282 /* Finally resolve if this is an array or not. */
8283 if (sym
->attr
.dimension
&& target
->rank
== 0)
8285 gfc_error ("Associate-name '%s' at %L is used as array",
8286 sym
->name
, &sym
->declared_at
);
8287 sym
->attr
.dimension
= 0;
8291 /* We cannot deal with class selectors that need temporaries. */
8292 if (target
->ts
.type
== BT_CLASS
8293 && gfc_ref_needs_temporary_p (target
->ref
))
8295 gfc_error ("CLASS selector at %L needs a temporary which is not "
8296 "yet implemented", &target
->where
);
8300 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8301 sym
->attr
.dimension
= 1;
8302 else if (target
->ts
.type
== BT_CLASS
)
8303 gfc_fix_class_refs (target
);
8305 /* The associate-name will have a correct type by now. Make absolutely
8306 sure that it has not picked up a dimension attribute. */
8307 if (sym
->ts
.type
== BT_CLASS
)
8308 sym
->attr
.dimension
= 0;
8310 if (sym
->attr
.dimension
)
8312 sym
->as
= gfc_get_array_spec ();
8313 sym
->as
->rank
= target
->rank
;
8314 sym
->as
->type
= AS_DEFERRED
;
8316 /* Target must not be coindexed, thus the associate-variable
8318 sym
->as
->corank
= 0;
8321 /* Mark this as an associate variable. */
8322 sym
->attr
.associate_var
= 1;
8324 /* If the target is a good class object, so is the associate variable. */
8325 if (sym
->ts
.type
== BT_CLASS
&& gfc_expr_attr (target
).class_ok
)
8326 sym
->attr
.class_ok
= 1;
8330 /* Resolve a SELECT TYPE statement. */
8333 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8335 gfc_symbol
*selector_type
;
8336 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8337 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8340 char name
[GFC_MAX_SYMBOL_LEN
];
8345 ns
= code
->ext
.block
.ns
;
8348 /* Check for F03:C813. */
8349 if (code
->expr1
->ts
.type
!= BT_CLASS
8350 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8352 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8353 "at %L", &code
->loc
);
8357 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8362 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8363 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8364 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8366 /* F2008: C803 The selector expression must not be coindexed. */
8367 if (gfc_is_coindexed (code
->expr2
))
8369 gfc_error ("Selector at %L must not be coindexed",
8370 &code
->expr2
->where
);
8377 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8379 if (gfc_is_coindexed (code
->expr1
))
8381 gfc_error ("Selector at %L must not be coindexed",
8382 &code
->expr1
->where
);
8387 /* Loop over TYPE IS / CLASS IS cases. */
8388 for (body
= code
->block
; body
; body
= body
->block
)
8390 c
= body
->ext
.block
.case_list
;
8392 /* Check F03:C815. */
8393 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8394 && !selector_type
->attr
.unlimited_polymorphic
8395 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8397 gfc_error ("Derived type '%s' at %L must be extensible",
8398 c
->ts
.u
.derived
->name
, &c
->where
);
8403 /* Check F03:C816. */
8404 if (c
->ts
.type
!= BT_UNKNOWN
&& !selector_type
->attr
.unlimited_polymorphic
8405 && ((c
->ts
.type
!= BT_DERIVED
&& c
->ts
.type
!= BT_CLASS
)
8406 || !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
)))
8408 if (c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8409 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8410 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8412 gfc_error ("Unexpected intrinsic type '%s' at %L",
8413 gfc_basic_typename (c
->ts
.type
), &c
->where
);
8418 /* Check F03:C814. */
8419 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.u
.cl
->length
!= NULL
)
8421 gfc_error ("The type-spec at %L shall specify that each length "
8422 "type parameter is assumed", &c
->where
);
8427 /* Intercept the DEFAULT case. */
8428 if (c
->ts
.type
== BT_UNKNOWN
)
8430 /* Check F03:C818. */
8433 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8434 "by a second DEFAULT CASE at %L",
8435 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8440 default_case
= body
;
8447 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8448 target if present. If there are any EXIT statements referring to the
8449 SELECT TYPE construct, this is no problem because the gfc_code
8450 reference stays the same and EXIT is equally possible from the BLOCK
8451 it is changed to. */
8452 code
->op
= EXEC_BLOCK
;
8455 gfc_association_list
* assoc
;
8457 assoc
= gfc_get_association_list ();
8458 assoc
->st
= code
->expr1
->symtree
;
8459 assoc
->target
= gfc_copy_expr (code
->expr2
);
8460 assoc
->target
->where
= code
->expr2
->where
;
8461 /* assoc->variable will be set by resolve_assoc_var. */
8463 code
->ext
.block
.assoc
= assoc
;
8464 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8466 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8469 code
->ext
.block
.assoc
= NULL
;
8471 /* Add EXEC_SELECT to switch on type. */
8472 new_st
= gfc_get_code ();
8473 new_st
->op
= code
->op
;
8474 new_st
->expr1
= code
->expr1
;
8475 new_st
->expr2
= code
->expr2
;
8476 new_st
->block
= code
->block
;
8477 code
->expr1
= code
->expr2
= NULL
;
8482 ns
->code
->next
= new_st
;
8484 code
->op
= EXEC_SELECT
;
8486 gfc_add_vptr_component (code
->expr1
);
8487 gfc_add_hash_component (code
->expr1
);
8489 /* Loop over TYPE IS / CLASS IS cases. */
8490 for (body
= code
->block
; body
; body
= body
->block
)
8492 c
= body
->ext
.block
.case_list
;
8494 if (c
->ts
.type
== BT_DERIVED
)
8495 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8496 c
->ts
.u
.derived
->hash_value
);
8497 else if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8502 ivtab
= gfc_find_intrinsic_vtab (&c
->ts
);
8503 gcc_assert (ivtab
&& CLASS_DATA (ivtab
)->initializer
);
8504 e
= CLASS_DATA (ivtab
)->initializer
;
8505 c
->low
= c
->high
= gfc_copy_expr (e
);
8508 else if (c
->ts
.type
== BT_UNKNOWN
)
8511 /* Associate temporary to selector. This should only be done
8512 when this case is actually true, so build a new ASSOCIATE
8513 that does precisely this here (instead of using the
8516 if (c
->ts
.type
== BT_CLASS
)
8517 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8518 else if (c
->ts
.type
== BT_DERIVED
)
8519 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8520 else if (c
->ts
.type
== BT_CHARACTER
)
8522 if (c
->ts
.u
.cl
&& c
->ts
.u
.cl
->length
8523 && c
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8524 charlen
= mpz_get_si (c
->ts
.u
.cl
->length
->value
.integer
);
8525 sprintf (name
, "__tmp_%s_%d_%d", gfc_basic_typename (c
->ts
.type
),
8526 charlen
, c
->ts
.kind
);
8529 sprintf (name
, "__tmp_%s_%d", gfc_basic_typename (c
->ts
.type
),
8532 st
= gfc_find_symtree (ns
->sym_root
, name
);
8533 gcc_assert (st
->n
.sym
->assoc
);
8534 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8535 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8536 if (c
->ts
.type
!= BT_CLASS
&& c
->ts
.type
!= BT_UNKNOWN
)
8537 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8539 new_st
= gfc_get_code ();
8540 new_st
->op
= EXEC_BLOCK
;
8541 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8542 new_st
->ext
.block
.ns
->code
= body
->next
;
8543 body
->next
= new_st
;
8545 /* Chain in the new list only if it is marked as dangling. Otherwise
8546 there is a CASE label overlap and this is already used. Just ignore,
8547 the error is diagnosed elsewhere. */
8548 if (st
->n
.sym
->assoc
->dangling
)
8550 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8551 st
->n
.sym
->assoc
->dangling
= 0;
8554 resolve_assoc_var (st
->n
.sym
, false);
8557 /* Take out CLASS IS cases for separate treatment. */
8559 while (body
&& body
->block
)
8561 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8563 /* Add to class_is list. */
8564 if (class_is
== NULL
)
8566 class_is
= body
->block
;
8571 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8572 tail
->block
= body
->block
;
8575 /* Remove from EXEC_SELECT list. */
8576 body
->block
= body
->block
->block
;
8589 /* Add a default case to hold the CLASS IS cases. */
8590 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8591 tail
->block
= gfc_get_code ();
8593 tail
->op
= EXEC_SELECT_TYPE
;
8594 tail
->ext
.block
.case_list
= gfc_get_case ();
8595 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8597 default_case
= tail
;
8600 /* More than one CLASS IS block? */
8601 if (class_is
->block
)
8605 /* Sort CLASS IS blocks by extension level. */
8609 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8612 /* F03:C817 (check for doubles). */
8613 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8614 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8616 gfc_error ("Double CLASS IS block in SELECT TYPE "
8618 &c2
->ext
.block
.case_list
->where
);
8621 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8622 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8625 (*c1
)->block
= c2
->block
;
8635 /* Generate IF chain. */
8636 if_st
= gfc_get_code ();
8637 if_st
->op
= EXEC_IF
;
8639 for (body
= class_is
; body
; body
= body
->block
)
8641 new_st
->block
= gfc_get_code ();
8642 new_st
= new_st
->block
;
8643 new_st
->op
= EXEC_IF
;
8644 /* Set up IF condition: Call _gfortran_is_extension_of. */
8645 new_st
->expr1
= gfc_get_expr ();
8646 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8647 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8648 new_st
->expr1
->ts
.kind
= 4;
8649 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8650 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8651 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8652 /* Set up arguments. */
8653 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8654 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8655 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8656 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8657 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8658 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8659 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8660 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8661 new_st
->next
= body
->next
;
8663 if (default_case
->next
)
8665 new_st
->block
= gfc_get_code ();
8666 new_st
= new_st
->block
;
8667 new_st
->op
= EXEC_IF
;
8668 new_st
->next
= default_case
->next
;
8671 /* Replace CLASS DEFAULT code by the IF chain. */
8672 default_case
->next
= if_st
;
8675 /* Resolve the internal code. This can not be done earlier because
8676 it requires that the sym->assoc of selectors is set already. */
8677 gfc_current_ns
= ns
;
8678 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8679 gfc_current_ns
= old_ns
;
8681 resolve_select (code
, true);
8685 /* Resolve a transfer statement. This is making sure that:
8686 -- a derived type being transferred has only non-pointer components
8687 -- a derived type being transferred doesn't have private components, unless
8688 it's being transferred from the module where the type was defined
8689 -- we're not trying to transfer a whole assumed size array. */
8692 resolve_transfer (gfc_code
*code
)
8701 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8702 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8703 exp
= exp
->value
.op
.op1
;
8705 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8707 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8708 "MOLD=", &exp
->where
);
8712 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8713 && exp
->expr_type
!= EXPR_FUNCTION
))
8716 /* If we are reading, the variable will be changed. Note that
8717 code->ext.dt may be NULL if the TRANSFER is related to
8718 an INQUIRE statement -- but in this case, we are not reading, either. */
8719 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8720 && gfc_check_vardef_context (exp
, false, false, false, _("item in READ"))
8724 sym
= exp
->symtree
->n
.sym
;
8727 /* Go to actual component transferred. */
8728 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8729 if (ref
->type
== REF_COMPONENT
)
8730 ts
= &ref
->u
.c
.component
->ts
;
8732 if (ts
->type
== BT_CLASS
)
8734 /* FIXME: Test for defined input/output. */
8735 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8736 "it is processed by a defined input/output procedure",
8741 if (ts
->type
== BT_DERIVED
)
8743 /* Check that transferred derived type doesn't contain POINTER
8745 if (ts
->u
.derived
->attr
.pointer_comp
)
8747 gfc_error ("Data transfer element at %L cannot have POINTER "
8748 "components unless it is processed by a defined "
8749 "input/output procedure", &code
->loc
);
8754 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8756 gfc_error ("Data transfer element at %L cannot have "
8757 "procedure pointer components", &code
->loc
);
8761 if (ts
->u
.derived
->attr
.alloc_comp
)
8763 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8764 "components unless it is processed by a defined "
8765 "input/output procedure", &code
->loc
);
8769 if (derived_inaccessible (ts
->u
.derived
))
8771 gfc_error ("Data transfer element at %L cannot have "
8772 "PRIVATE components",&code
->loc
);
8777 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8778 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8780 gfc_error ("Data transfer element at %L cannot be a full reference to "
8781 "an assumed-size array", &code
->loc
);
8787 /*********** Toplevel code resolution subroutines ***********/
8789 /* Find the set of labels that are reachable from this block. We also
8790 record the last statement in each block. */
8793 find_reachable_labels (gfc_code
*block
)
8800 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8802 /* Collect labels in this block. We don't keep those corresponding
8803 to END {IF|SELECT}, these are checked in resolve_branch by going
8804 up through the code_stack. */
8805 for (c
= block
; c
; c
= c
->next
)
8807 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8808 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8811 /* Merge with labels from parent block. */
8814 gcc_assert (cs_base
->prev
->reachable_labels
);
8815 bitmap_ior_into (cs_base
->reachable_labels
,
8816 cs_base
->prev
->reachable_labels
);
8822 resolve_lock_unlock (gfc_code
*code
)
8824 if (code
->expr1
->ts
.type
!= BT_DERIVED
8825 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8826 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8827 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8828 || code
->expr1
->rank
!= 0
8829 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8830 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8831 &code
->expr1
->where
);
8835 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8836 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8837 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8838 &code
->expr2
->where
);
8841 && gfc_check_vardef_context (code
->expr2
, false, false, false,
8842 _("STAT variable")) == FAILURE
)
8847 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8848 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8849 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8850 &code
->expr3
->where
);
8853 && gfc_check_vardef_context (code
->expr3
, false, false, false,
8854 _("ERRMSG variable")) == FAILURE
)
8857 /* Check ACQUIRED_LOCK. */
8859 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8860 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8861 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8862 "variable", &code
->expr4
->where
);
8865 && gfc_check_vardef_context (code
->expr4
, false, false, false,
8866 _("ACQUIRED_LOCK variable")) == FAILURE
)
8872 resolve_sync (gfc_code
*code
)
8874 /* Check imageset. The * case matches expr1 == NULL. */
8877 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8878 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8879 "INTEGER expression", &code
->expr1
->where
);
8880 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8881 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8882 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8883 &code
->expr1
->where
);
8884 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8885 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8887 gfc_constructor
*cons
;
8888 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8889 for (; cons
; cons
= gfc_constructor_next (cons
))
8890 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8891 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8892 gfc_error ("Imageset argument at %L must between 1 and "
8893 "num_images()", &cons
->expr
->where
);
8899 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8900 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8901 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8902 &code
->expr2
->where
);
8906 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8907 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8908 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8909 &code
->expr3
->where
);
8913 /* Given a branch to a label, see if the branch is conforming.
8914 The code node describes where the branch is located. */
8917 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8924 /* Step one: is this a valid branching target? */
8926 if (label
->defined
== ST_LABEL_UNKNOWN
)
8928 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8933 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8935 gfc_error ("Statement at %L is not a valid branch target statement "
8936 "for the branch statement at %L", &label
->where
, &code
->loc
);
8940 /* Step two: make sure this branch is not a branch to itself ;-) */
8942 if (code
->here
== label
)
8944 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8948 /* Step three: See if the label is in the same block as the
8949 branching statement. The hard work has been done by setting up
8950 the bitmap reachable_labels. */
8952 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8954 /* Check now whether there is a CRITICAL construct; if so, check
8955 whether the label is still visible outside of the CRITICAL block,
8956 which is invalid. */
8957 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8959 if (stack
->current
->op
== EXEC_CRITICAL
8960 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8961 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8962 "label at %L", &code
->loc
, &label
->where
);
8963 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8964 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8965 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8966 "for label at %L", &code
->loc
, &label
->where
);
8972 /* Step four: If we haven't found the label in the bitmap, it may
8973 still be the label of the END of the enclosing block, in which
8974 case we find it by going up the code_stack. */
8976 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8978 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8980 if (stack
->current
->op
== EXEC_CRITICAL
)
8982 /* Note: A label at END CRITICAL does not leave the CRITICAL
8983 construct as END CRITICAL is still part of it. */
8984 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8985 " at %L", &code
->loc
, &label
->where
);
8988 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8990 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8991 "label at %L", &code
->loc
, &label
->where
);
8998 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
9002 /* The label is not in an enclosing block, so illegal. This was
9003 allowed in Fortran 66, so we allow it as extension. No
9004 further checks are necessary in this case. */
9005 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
9006 "as the GOTO statement at %L", &label
->where
,
9012 /* Check whether EXPR1 has the same shape as EXPR2. */
9015 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
9017 mpz_t shape
[GFC_MAX_DIMENSIONS
];
9018 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
9019 gfc_try result
= FAILURE
;
9022 /* Compare the rank. */
9023 if (expr1
->rank
!= expr2
->rank
)
9026 /* Compare the size of each dimension. */
9027 for (i
=0; i
<expr1
->rank
; i
++)
9029 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
9032 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
9035 if (mpz_cmp (shape
[i
], shape2
[i
]))
9039 /* When either of the two expression is an assumed size array, we
9040 ignore the comparison of dimension sizes. */
9045 gfc_clear_shape (shape
, i
);
9046 gfc_clear_shape (shape2
, i
);
9051 /* Check whether a WHERE assignment target or a WHERE mask expression
9052 has the same shape as the outmost WHERE mask expression. */
9055 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
9061 cblock
= code
->block
;
9063 /* Store the first WHERE mask-expr of the WHERE statement or construct.
9064 In case of nested WHERE, only the outmost one is stored. */
9065 if (mask
== NULL
) /* outmost WHERE */
9067 else /* inner WHERE */
9074 /* Check if the mask-expr has a consistent shape with the
9075 outmost WHERE mask-expr. */
9076 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
9077 gfc_error ("WHERE mask at %L has inconsistent shape",
9078 &cblock
->expr1
->where
);
9081 /* the assignment statement of a WHERE statement, or the first
9082 statement in where-body-construct of a WHERE construct */
9083 cnext
= cblock
->next
;
9088 /* WHERE assignment statement */
9091 /* Check shape consistent for WHERE assignment target. */
9092 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
9093 gfc_error ("WHERE assignment target at %L has "
9094 "inconsistent shape", &cnext
->expr1
->where
);
9098 case EXEC_ASSIGN_CALL
:
9099 resolve_call (cnext
);
9100 if (!cnext
->resolved_sym
->attr
.elemental
)
9101 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9102 &cnext
->ext
.actual
->expr
->where
);
9105 /* WHERE or WHERE construct is part of a where-body-construct */
9107 resolve_where (cnext
, e
);
9111 gfc_error ("Unsupported statement inside WHERE at %L",
9114 /* the next statement within the same where-body-construct */
9115 cnext
= cnext
->next
;
9117 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9118 cblock
= cblock
->block
;
9123 /* Resolve assignment in FORALL construct.
9124 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9125 FORALL index variables. */
9128 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9132 for (n
= 0; n
< nvar
; n
++)
9134 gfc_symbol
*forall_index
;
9136 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9138 /* Check whether the assignment target is one of the FORALL index
9140 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9141 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9142 gfc_error ("Assignment to a FORALL index variable at %L",
9143 &code
->expr1
->where
);
9146 /* If one of the FORALL index variables doesn't appear in the
9147 assignment variable, then there could be a many-to-one
9148 assignment. Emit a warning rather than an error because the
9149 mask could be resolving this problem. */
9150 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
9151 gfc_warning ("The FORALL with index '%s' is not used on the "
9152 "left side of the assignment at %L and so might "
9153 "cause multiple assignment to this object",
9154 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9160 /* Resolve WHERE statement in FORALL construct. */
9163 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9164 gfc_expr
**var_expr
)
9169 cblock
= code
->block
;
9172 /* the assignment statement of a WHERE statement, or the first
9173 statement in where-body-construct of a WHERE construct */
9174 cnext
= cblock
->next
;
9179 /* WHERE assignment statement */
9181 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9184 /* WHERE operator assignment statement */
9185 case EXEC_ASSIGN_CALL
:
9186 resolve_call (cnext
);
9187 if (!cnext
->resolved_sym
->attr
.elemental
)
9188 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9189 &cnext
->ext
.actual
->expr
->where
);
9192 /* WHERE or WHERE construct is part of a where-body-construct */
9194 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9198 gfc_error ("Unsupported statement inside WHERE at %L",
9201 /* the next statement within the same where-body-construct */
9202 cnext
= cnext
->next
;
9204 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9205 cblock
= cblock
->block
;
9210 /* Traverse the FORALL body to check whether the following errors exist:
9211 1. For assignment, check if a many-to-one assignment happens.
9212 2. For WHERE statement, check the WHERE body to see if there is any
9213 many-to-one assignment. */
9216 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9220 c
= code
->block
->next
;
9226 case EXEC_POINTER_ASSIGN
:
9227 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9230 case EXEC_ASSIGN_CALL
:
9234 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9235 there is no need to handle it here. */
9239 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9244 /* The next statement in the FORALL body. */
9250 /* Counts the number of iterators needed inside a forall construct, including
9251 nested forall constructs. This is used to allocate the needed memory
9252 in gfc_resolve_forall. */
9255 gfc_count_forall_iterators (gfc_code
*code
)
9257 int max_iters
, sub_iters
, current_iters
;
9258 gfc_forall_iterator
*fa
;
9260 gcc_assert(code
->op
== EXEC_FORALL
);
9264 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9267 code
= code
->block
->next
;
9271 if (code
->op
== EXEC_FORALL
)
9273 sub_iters
= gfc_count_forall_iterators (code
);
9274 if (sub_iters
> max_iters
)
9275 max_iters
= sub_iters
;
9280 return current_iters
+ max_iters
;
9284 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9285 gfc_resolve_forall_body to resolve the FORALL body. */
9288 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9290 static gfc_expr
**var_expr
;
9291 static int total_var
= 0;
9292 static int nvar
= 0;
9294 gfc_forall_iterator
*fa
;
9299 /* Start to resolve a FORALL construct */
9300 if (forall_save
== 0)
9302 /* Count the total number of FORALL index in the nested FORALL
9303 construct in order to allocate the VAR_EXPR with proper size. */
9304 total_var
= gfc_count_forall_iterators (code
);
9306 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9307 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9310 /* The information about FORALL iterator, including FORALL index start, end
9311 and stride. The FORALL index can not appear in start, end or stride. */
9312 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9314 /* Check if any outer FORALL index name is the same as the current
9316 for (i
= 0; i
< nvar
; i
++)
9318 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9320 gfc_error ("An outer FORALL construct already has an index "
9321 "with this name %L", &fa
->var
->where
);
9325 /* Record the current FORALL index. */
9326 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9330 /* No memory leak. */
9331 gcc_assert (nvar
<= total_var
);
9334 /* Resolve the FORALL body. */
9335 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9337 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9338 gfc_resolve_blocks (code
->block
, ns
);
9342 /* Free only the VAR_EXPRs allocated in this frame. */
9343 for (i
= nvar
; i
< tmp
; i
++)
9344 gfc_free_expr (var_expr
[i
]);
9348 /* We are in the outermost FORALL construct. */
9349 gcc_assert (forall_save
== 0);
9351 /* VAR_EXPR is not needed any more. */
9358 /* Resolve a BLOCK construct statement. */
9361 resolve_block_construct (gfc_code
* code
)
9363 /* Resolve the BLOCK's namespace. */
9364 gfc_resolve (code
->ext
.block
.ns
);
9366 /* For an ASSOCIATE block, the associations (and their targets) are already
9367 resolved during resolve_symbol. */
9371 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9374 static void resolve_code (gfc_code
*, gfc_namespace
*);
9377 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9381 for (; b
; b
= b
->block
)
9383 t
= gfc_resolve_expr (b
->expr1
);
9384 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
9390 if (t
== SUCCESS
&& b
->expr1
!= NULL
9391 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9392 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9399 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9400 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9405 resolve_branch (b
->label1
, b
);
9409 resolve_block_construct (b
);
9413 case EXEC_SELECT_TYPE
:
9417 case EXEC_DO_CONCURRENT
:
9425 case EXEC_OMP_ATOMIC
:
9426 case EXEC_OMP_CRITICAL
:
9428 case EXEC_OMP_MASTER
:
9429 case EXEC_OMP_ORDERED
:
9430 case EXEC_OMP_PARALLEL
:
9431 case EXEC_OMP_PARALLEL_DO
:
9432 case EXEC_OMP_PARALLEL_SECTIONS
:
9433 case EXEC_OMP_PARALLEL_WORKSHARE
:
9434 case EXEC_OMP_SECTIONS
:
9435 case EXEC_OMP_SINGLE
:
9437 case EXEC_OMP_TASKWAIT
:
9438 case EXEC_OMP_TASKYIELD
:
9439 case EXEC_OMP_WORKSHARE
:
9443 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9446 resolve_code (b
->next
, ns
);
9451 /* Does everything to resolve an ordinary assignment. Returns true
9452 if this is an interface assignment. */
9454 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9464 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9468 if (code
->op
== EXEC_ASSIGN_CALL
)
9470 lhs
= code
->ext
.actual
->expr
;
9471 rhsptr
= &code
->ext
.actual
->next
->expr
;
9475 gfc_actual_arglist
* args
;
9476 gfc_typebound_proc
* tbp
;
9478 gcc_assert (code
->op
== EXEC_COMPCALL
);
9480 args
= code
->expr1
->value
.compcall
.actual
;
9482 rhsptr
= &args
->next
->expr
;
9484 tbp
= code
->expr1
->value
.compcall
.tbp
;
9485 gcc_assert (!tbp
->is_generic
);
9488 /* Make a temporary rhs when there is a default initializer
9489 and rhs is the same symbol as the lhs. */
9490 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9491 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9492 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9493 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9494 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9503 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9504 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9505 &code
->loc
) == FAILURE
)
9508 /* Handle the case of a BOZ literal on the RHS. */
9509 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9512 if (gfc_option
.warn_surprising
)
9513 gfc_warning ("BOZ literal at %L is bitwise transferred "
9514 "non-integer symbol '%s'", &code
->loc
,
9515 lhs
->symtree
->n
.sym
->name
);
9517 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9519 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9521 if (rc
== ARITH_UNDERFLOW
)
9522 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9523 ". This check can be disabled with the option "
9524 "-fno-range-check", &rhs
->where
);
9525 else if (rc
== ARITH_OVERFLOW
)
9526 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9527 ". This check can be disabled with the option "
9528 "-fno-range-check", &rhs
->where
);
9529 else if (rc
== ARITH_NAN
)
9530 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9531 ". This check can be disabled with the option "
9532 "-fno-range-check", &rhs
->where
);
9537 if (lhs
->ts
.type
== BT_CHARACTER
9538 && gfc_option
.warn_character_truncation
)
9540 if (lhs
->ts
.u
.cl
!= NULL
9541 && lhs
->ts
.u
.cl
->length
!= NULL
9542 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9543 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9545 if (rhs
->expr_type
== EXPR_CONSTANT
)
9546 rlen
= rhs
->value
.character
.length
;
9548 else if (rhs
->ts
.u
.cl
!= NULL
9549 && rhs
->ts
.u
.cl
->length
!= NULL
9550 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9551 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9553 if (rlen
&& llen
&& rlen
> llen
)
9554 gfc_warning_now ("CHARACTER expression will be truncated "
9555 "in assignment (%d/%d) at %L",
9556 llen
, rlen
, &code
->loc
);
9559 /* Ensure that a vector index expression for the lvalue is evaluated
9560 to a temporary if the lvalue symbol is referenced in it. */
9563 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9564 if (ref
->type
== REF_ARRAY
)
9566 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9567 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9568 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9569 ref
->u
.ar
.start
[n
]))
9571 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9575 if (gfc_pure (NULL
))
9577 if (lhs
->ts
.type
== BT_DERIVED
9578 && lhs
->expr_type
== EXPR_VARIABLE
9579 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9580 && rhs
->expr_type
== EXPR_VARIABLE
9581 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9582 || gfc_is_coindexed (rhs
)))
9585 if (gfc_is_coindexed (rhs
))
9586 gfc_error ("Coindexed expression at %L is assigned to "
9587 "a derived type variable with a POINTER "
9588 "component in a PURE procedure",
9591 gfc_error ("The impure variable at %L is assigned to "
9592 "a derived type variable with a POINTER "
9593 "component in a PURE procedure (12.6)",
9598 /* Fortran 2008, C1283. */
9599 if (gfc_is_coindexed (lhs
))
9601 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9602 "procedure", &rhs
->where
);
9607 if (gfc_implicit_pure (NULL
))
9609 if (lhs
->expr_type
== EXPR_VARIABLE
9610 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9611 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9612 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9614 if (lhs
->ts
.type
== BT_DERIVED
9615 && lhs
->expr_type
== EXPR_VARIABLE
9616 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9617 && rhs
->expr_type
== EXPR_VARIABLE
9618 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9619 || gfc_is_coindexed (rhs
)))
9620 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9622 /* Fortran 2008, C1283. */
9623 if (gfc_is_coindexed (lhs
))
9624 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9628 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9629 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9630 if (lhs
->ts
.type
== BT_CLASS
)
9632 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9633 "%L - check that there is a matching specific subroutine "
9634 "for '=' operator", &lhs
->where
);
9638 /* F2008, Section 7.2.1.2. */
9639 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9641 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9642 "component in assignment at %L", &lhs
->where
);
9646 gfc_check_assign (lhs
, rhs
, 1);
9651 /* Add a component reference onto an expression. */
9654 add_comp_ref (gfc_expr
*e
, gfc_component
*c
)
9659 ref
= &((*ref
)->next
);
9660 *ref
= gfc_get_ref ();
9661 (*ref
)->type
= REF_COMPONENT
;
9662 (*ref
)->u
.c
.sym
= e
->ts
.u
.derived
;
9663 (*ref
)->u
.c
.component
= c
;
9666 /* Add a full array ref, as necessary. */
9669 gfc_add_full_array_ref (e
, c
->as
);
9670 e
->rank
= c
->as
->rank
;
9675 /* Build an assignment. Keep the argument 'op' for future use, so that
9676 pointer assignments can be made. */
9679 build_assignment (gfc_exec_op op
, gfc_expr
*expr1
, gfc_expr
*expr2
,
9680 gfc_component
*comp1
, gfc_component
*comp2
, locus loc
)
9682 gfc_code
*this_code
;
9684 this_code
= gfc_get_code ();
9686 this_code
->next
= NULL
;
9687 this_code
->expr1
= gfc_copy_expr (expr1
);
9688 this_code
->expr2
= gfc_copy_expr (expr2
);
9689 this_code
->loc
= loc
;
9692 add_comp_ref (this_code
->expr1
, comp1
);
9693 add_comp_ref (this_code
->expr2
, comp2
);
9700 /* Makes a temporary variable expression based on the characteristics of
9701 a given variable expression. */
9704 get_temp_from_expr (gfc_expr
*e
, gfc_namespace
*ns
)
9706 static int serial
= 0;
9707 char name
[GFC_MAX_SYMBOL_LEN
];
9710 gfc_array_ref
*aref
;
9713 sprintf (name
, "DA@%d", serial
++);
9714 gfc_get_sym_tree (name
, ns
, &tmp
, false);
9715 gfc_add_type (tmp
->n
.sym
, &e
->ts
, NULL
);
9721 /* This function could be expanded to support other expression type
9722 but this is not needed here. */
9723 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
9725 /* Obtain the arrayspec for the temporary. */
9728 aref
= gfc_find_array_ref (e
);
9729 if (e
->expr_type
== EXPR_VARIABLE
9730 && e
->symtree
->n
.sym
->as
== aref
->as
)
9734 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9735 if (ref
->type
== REF_COMPONENT
9736 && ref
->u
.c
.component
->as
== aref
->as
)
9744 /* Add the attributes and the arrayspec to the temporary. */
9745 tmp
->n
.sym
->attr
= gfc_expr_attr (e
);
9748 tmp
->n
.sym
->as
= gfc_copy_array_spec (as
);
9751 if (as
->type
== AS_DEFERRED
)
9752 tmp
->n
.sym
->attr
.allocatable
= 1;
9755 tmp
->n
.sym
->attr
.dimension
= 0;
9757 gfc_set_sym_referenced (tmp
->n
.sym
);
9758 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
9759 e
= gfc_lval_expr_from_sym (tmp
->n
.sym
);
9761 /* Should the lhs be a section, use its array ref for the
9762 temporary expression. */
9763 if (aref
&& aref
->type
!= AR_FULL
)
9765 gfc_free_ref_list (e
->ref
);
9766 e
->ref
= gfc_copy_ref (ref
);
9772 /* Add one line of code to the code chain, making sure that 'head' and
9773 'tail' are appropriately updated. */
9776 add_code_to_chain (gfc_code
**this_code
, gfc_code
**head
, gfc_code
**tail
)
9778 gcc_assert (this_code
);
9780 *head
= *tail
= *this_code
;
9782 *tail
= gfc_append_code (*tail
, *this_code
);
9787 /* Counts the potential number of part array references that would
9788 result from resolution of typebound defined assignments. */
9791 nonscalar_typebound_assign (gfc_symbol
*derived
, int depth
)
9794 int c_depth
= 0, t_depth
;
9796 for (c
= derived
->components
; c
; c
= c
->next
)
9798 if ((c
->ts
.type
!= BT_DERIVED
9800 || c
->attr
.allocatable
9801 || c
->attr
.proc_pointer_comp
9802 || c
->attr
.class_pointer
9803 || c
->attr
.proc_pointer
)
9804 && !c
->attr
.defined_assign_comp
)
9807 if (c
->as
&& c_depth
== 0)
9810 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
9811 t_depth
= nonscalar_typebound_assign (c
->ts
.u
.derived
,
9816 c_depth
= t_depth
> c_depth
? t_depth
: c_depth
;
9818 return depth
+ c_depth
;
9822 /* Implement 7.2.1.3 of the F08 standard:
9823 "An intrinsic assignment where the variable is of derived type is
9824 performed as if each component of the variable were assigned from the
9825 corresponding component of expr using pointer assignment (7.2.2) for
9826 each pointer component, defined assignment for each nonpointer
9827 nonallocatable component of a type that has a type-bound defined
9828 assignment consistent with the component, intrinsic assignment for
9829 each other nonpointer nonallocatable component, ..."
9831 The pointer assignments are taken care of by the intrinsic
9832 assignment of the structure itself. This function recursively adds
9833 defined assignments where required. The recursion is accomplished
9834 by calling resolve_code.
9836 When the lhs in a defined assignment has intent INOUT, we need a
9837 temporary for the lhs. In pseudo-code:
9839 ! Only call function lhs once.
9840 if (lhs is not a constant or an variable)
9843 ! Do the intrinsic assignment
9845 ! Now do the defined assignments
9846 do over components with typebound defined assignment [%cmp]
9847 #if one component's assignment procedure is INOUT
9849 #if expr2 non-variable
9855 t1%cmp {defined=} expr2%cmp
9861 expr1%cmp {defined=} expr2%cmp
9865 /* The temporary assignments have to be put on top of the additional
9866 code to avoid the result being changed by the intrinsic assignment.
9868 static int component_assignment_level
= 0;
9869 static gfc_code
*tmp_head
= NULL
, *tmp_tail
= NULL
;
9872 generate_component_assignments (gfc_code
**code
, gfc_namespace
*ns
)
9874 gfc_component
*comp1
, *comp2
;
9875 gfc_code
*this_code
= NULL
, *head
= NULL
, *tail
= NULL
;
9877 int error_count
, depth
;
9879 gfc_get_errors (NULL
, &error_count
);
9881 /* Filter out continuing processing after an error. */
9883 || (*code
)->expr1
->ts
.type
!= BT_DERIVED
9884 || (*code
)->expr2
->ts
.type
!= BT_DERIVED
)
9887 /* TODO: Handle more than one part array reference in assignments. */
9888 depth
= nonscalar_typebound_assign ((*code
)->expr1
->ts
.u
.derived
,
9889 (*code
)->expr1
->rank
? 1 : 0);
9892 gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
9893 "done because multiple part array references would "
9894 "occur in intermediate expressions.", &(*code
)->loc
);
9898 component_assignment_level
++;
9900 /* Create a temporary so that functions get called only once. */
9901 if ((*code
)->expr2
->expr_type
!= EXPR_VARIABLE
9902 && (*code
)->expr2
->expr_type
!= EXPR_CONSTANT
)
9906 /* Assign the rhs to the temporary. */
9907 tmp_expr
= get_temp_from_expr ((*code
)->expr1
, ns
);
9908 this_code
= build_assignment (EXEC_ASSIGN
,
9909 tmp_expr
, (*code
)->expr2
,
9910 NULL
, NULL
, (*code
)->loc
);
9911 /* Add the code and substitute the rhs expression. */
9912 add_code_to_chain (&this_code
, &tmp_head
, &tmp_tail
);
9913 gfc_free_expr ((*code
)->expr2
);
9914 (*code
)->expr2
= tmp_expr
;
9917 /* Do the intrinsic assignment. This is not needed if the lhs is one
9918 of the temporaries generated here, since the intrinsic assignment
9919 to the final result already does this. */
9920 if ((*code
)->expr1
->symtree
->n
.sym
->name
[2] != '@')
9922 this_code
= build_assignment (EXEC_ASSIGN
,
9923 (*code
)->expr1
, (*code
)->expr2
,
9924 NULL
, NULL
, (*code
)->loc
);
9925 add_code_to_chain (&this_code
, &head
, &tail
);
9928 comp1
= (*code
)->expr1
->ts
.u
.derived
->components
;
9929 comp2
= (*code
)->expr2
->ts
.u
.derived
->components
;
9932 for (; comp1
; comp1
= comp1
->next
, comp2
= comp2
->next
)
9936 /* The intrinsic assignment does the right thing for pointers
9937 of all kinds and allocatable components. */
9938 if (comp1
->ts
.type
!= BT_DERIVED
9939 || comp1
->attr
.pointer
9940 || comp1
->attr
.allocatable
9941 || comp1
->attr
.proc_pointer_comp
9942 || comp1
->attr
.class_pointer
9943 || comp1
->attr
.proc_pointer
)
9946 /* Make an assigment for this component. */
9947 this_code
= build_assignment (EXEC_ASSIGN
,
9948 (*code
)->expr1
, (*code
)->expr2
,
9949 comp1
, comp2
, (*code
)->loc
);
9951 /* Convert the assignment if there is a defined assignment for
9952 this type. Otherwise, using the call from resolve_code,
9953 recurse into its components. */
9954 resolve_code (this_code
, ns
);
9956 if (this_code
->op
== EXEC_ASSIGN_CALL
)
9958 gfc_formal_arglist
*dummy_args
;
9960 /* Check that there is a typebound defined assignment. If not,
9961 then this must be a module defined assignment. We cannot
9962 use the defined_assign_comp attribute here because it must
9963 be this derived type that has the defined assignment and not
9965 if (!(comp1
->ts
.u
.derived
->f2k_derived
9966 && comp1
->ts
.u
.derived
->f2k_derived
9967 ->tb_op
[INTRINSIC_ASSIGN
]))
9969 gfc_free_statements (this_code
);
9974 /* If the first argument of the subroutine has intent INOUT
9975 a temporary must be generated and used instead. */
9976 rsym
= this_code
->resolved_sym
;
9977 dummy_args
= gfc_sym_get_dummy_args (rsym
);
9979 && dummy_args
->sym
->attr
.intent
== INTENT_INOUT
)
9981 gfc_code
*temp_code
;
9984 /* Build the temporary required for the assignment and put
9985 it at the head of the generated code. */
9988 t1
= get_temp_from_expr ((*code
)->expr1
, ns
);
9989 temp_code
= build_assignment (EXEC_ASSIGN
,
9991 NULL
, NULL
, (*code
)->loc
);
9992 add_code_to_chain (&temp_code
, &tmp_head
, &tmp_tail
);
9995 /* Replace the first actual arg with the component of the
9997 gfc_free_expr (this_code
->ext
.actual
->expr
);
9998 this_code
->ext
.actual
->expr
= gfc_copy_expr (t1
);
9999 add_comp_ref (this_code
->ext
.actual
->expr
, comp1
);
10002 else if (this_code
->op
== EXEC_ASSIGN
&& !this_code
->next
)
10004 /* Don't add intrinsic assignments since they are already
10005 effected by the intrinsic assignment of the structure. */
10006 gfc_free_statements (this_code
);
10011 add_code_to_chain (&this_code
, &head
, &tail
);
10015 /* Transfer the value to the final result. */
10016 this_code
= build_assignment (EXEC_ASSIGN
,
10017 (*code
)->expr1
, t1
,
10018 comp1
, comp2
, (*code
)->loc
);
10019 add_code_to_chain (&this_code
, &head
, &tail
);
10023 /* This is probably not necessary. */
10026 gfc_free_statements (this_code
);
10030 /* Put the temporary assignments at the top of the generated code. */
10031 if (tmp_head
&& component_assignment_level
== 1)
10033 gfc_append_code (tmp_head
, head
);
10035 tmp_head
= tmp_tail
= NULL
;
10038 /* Now attach the remaining code chain to the input code. Step on
10039 to the end of the new code since resolution is complete. */
10040 gcc_assert ((*code
)->op
== EXEC_ASSIGN
);
10041 tail
->next
= (*code
)->next
;
10042 /* Overwrite 'code' because this would place the intrinsic assignment
10043 before the temporary for the lhs is created. */
10044 gfc_free_expr ((*code
)->expr1
);
10045 gfc_free_expr ((*code
)->expr2
);
10050 component_assignment_level
--;
10054 /* Given a block of code, recursively resolve everything pointed to by this
10058 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
10060 int omp_workshare_save
;
10061 int forall_save
, do_concurrent_save
;
10065 frame
.prev
= cs_base
;
10069 find_reachable_labels (code
);
10071 for (; code
; code
= code
->next
)
10073 frame
.current
= code
;
10074 forall_save
= forall_flag
;
10075 do_concurrent_save
= do_concurrent_flag
;
10077 if (code
->op
== EXEC_FORALL
)
10080 gfc_resolve_forall (code
, ns
, forall_save
);
10083 else if (code
->block
)
10085 omp_workshare_save
= -1;
10088 case EXEC_OMP_PARALLEL_WORKSHARE
:
10089 omp_workshare_save
= omp_workshare_flag
;
10090 omp_workshare_flag
= 1;
10091 gfc_resolve_omp_parallel_blocks (code
, ns
);
10093 case EXEC_OMP_PARALLEL
:
10094 case EXEC_OMP_PARALLEL_DO
:
10095 case EXEC_OMP_PARALLEL_SECTIONS
:
10096 case EXEC_OMP_TASK
:
10097 omp_workshare_save
= omp_workshare_flag
;
10098 omp_workshare_flag
= 0;
10099 gfc_resolve_omp_parallel_blocks (code
, ns
);
10102 gfc_resolve_omp_do_blocks (code
, ns
);
10104 case EXEC_SELECT_TYPE
:
10105 /* Blocks are handled in resolve_select_type because we have
10106 to transform the SELECT TYPE into ASSOCIATE first. */
10108 case EXEC_DO_CONCURRENT
:
10109 do_concurrent_flag
= 1;
10110 gfc_resolve_blocks (code
->block
, ns
);
10111 do_concurrent_flag
= 2;
10113 case EXEC_OMP_WORKSHARE
:
10114 omp_workshare_save
= omp_workshare_flag
;
10115 omp_workshare_flag
= 1;
10118 gfc_resolve_blocks (code
->block
, ns
);
10122 if (omp_workshare_save
!= -1)
10123 omp_workshare_flag
= omp_workshare_save
;
10127 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
10128 t
= gfc_resolve_expr (code
->expr1
);
10129 forall_flag
= forall_save
;
10130 do_concurrent_flag
= do_concurrent_save
;
10132 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
10135 if (code
->op
== EXEC_ALLOCATE
10136 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
10142 case EXEC_END_BLOCK
:
10143 case EXEC_END_NESTED_BLOCK
:
10147 case EXEC_ERROR_STOP
:
10149 case EXEC_CONTINUE
:
10151 case EXEC_ASSIGN_CALL
:
10152 case EXEC_CRITICAL
:
10155 case EXEC_SYNC_ALL
:
10156 case EXEC_SYNC_IMAGES
:
10157 case EXEC_SYNC_MEMORY
:
10158 resolve_sync (code
);
10163 resolve_lock_unlock (code
);
10167 /* Keep track of which entry we are up to. */
10168 current_entry_id
= code
->ext
.entry
->id
;
10172 resolve_where (code
, NULL
);
10176 if (code
->expr1
!= NULL
)
10178 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
10179 gfc_error ("ASSIGNED GOTO statement at %L requires an "
10180 "INTEGER variable", &code
->expr1
->where
);
10181 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
10182 gfc_error ("Variable '%s' has not been assigned a target "
10183 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
10184 &code
->expr1
->where
);
10187 resolve_branch (code
->label1
, code
);
10191 if (code
->expr1
!= NULL
10192 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
10193 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
10194 "INTEGER return specifier", &code
->expr1
->where
);
10197 case EXEC_INIT_ASSIGN
:
10198 case EXEC_END_PROCEDURE
:
10205 if (gfc_check_vardef_context (code
->expr1
, false, false, false,
10206 _("assignment")) == FAILURE
)
10209 if (resolve_ordinary_assign (code
, ns
))
10211 if (code
->op
== EXEC_COMPCALL
)
10217 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */
10218 if (code
->expr1
->ts
.type
== BT_DERIVED
10219 && code
->expr1
->ts
.u
.derived
->attr
.defined_assign_comp
)
10220 generate_component_assignments (&code
, ns
);
10224 case EXEC_LABEL_ASSIGN
:
10225 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
10226 gfc_error ("Label %d referenced at %L is never defined",
10227 code
->label1
->value
, &code
->label1
->where
);
10229 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
10230 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
10231 || code
->expr1
->symtree
->n
.sym
->ts
.kind
10232 != gfc_default_integer_kind
10233 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
10234 gfc_error ("ASSIGN statement at %L requires a scalar "
10235 "default INTEGER variable", &code
->expr1
->where
);
10238 case EXEC_POINTER_ASSIGN
:
10245 /* This is both a variable definition and pointer assignment
10246 context, so check both of them. For rank remapping, a final
10247 array ref may be present on the LHS and fool gfc_expr_attr
10248 used in gfc_check_vardef_context. Remove it. */
10249 e
= remove_last_array_ref (code
->expr1
);
10250 t
= gfc_check_vardef_context (e
, true, false, false,
10251 _("pointer assignment"));
10253 t
= gfc_check_vardef_context (e
, false, false, false,
10254 _("pointer assignment"));
10259 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
10263 case EXEC_ARITHMETIC_IF
:
10265 && code
->expr1
->ts
.type
!= BT_INTEGER
10266 && code
->expr1
->ts
.type
!= BT_REAL
)
10267 gfc_error ("Arithmetic IF statement at %L requires a numeric "
10268 "expression", &code
->expr1
->where
);
10270 resolve_branch (code
->label1
, code
);
10271 resolve_branch (code
->label2
, code
);
10272 resolve_branch (code
->label3
, code
);
10276 if (t
== SUCCESS
&& code
->expr1
!= NULL
10277 && (code
->expr1
->ts
.type
!= BT_LOGICAL
10278 || code
->expr1
->rank
!= 0))
10279 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10280 &code
->expr1
->where
);
10285 resolve_call (code
);
10288 case EXEC_COMPCALL
:
10290 resolve_typebound_subroutine (code
);
10293 case EXEC_CALL_PPC
:
10294 resolve_ppc_call (code
);
10298 /* Select is complicated. Also, a SELECT construct could be
10299 a transformed computed GOTO. */
10300 resolve_select (code
, false);
10303 case EXEC_SELECT_TYPE
:
10304 resolve_select_type (code
, ns
);
10308 resolve_block_construct (code
);
10312 if (code
->ext
.iterator
!= NULL
)
10314 gfc_iterator
*iter
= code
->ext
.iterator
;
10315 if (gfc_resolve_iterator (iter
, true, false) != FAILURE
)
10316 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
10320 case EXEC_DO_WHILE
:
10321 if (code
->expr1
== NULL
)
10322 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
10324 && (code
->expr1
->rank
!= 0
10325 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
10326 gfc_error ("Exit condition of DO WHILE loop at %L must be "
10327 "a scalar LOGICAL expression", &code
->expr1
->where
);
10330 case EXEC_ALLOCATE
:
10332 resolve_allocate_deallocate (code
, "ALLOCATE");
10336 case EXEC_DEALLOCATE
:
10338 resolve_allocate_deallocate (code
, "DEALLOCATE");
10343 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
10346 resolve_branch (code
->ext
.open
->err
, code
);
10350 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
10353 resolve_branch (code
->ext
.close
->err
, code
);
10356 case EXEC_BACKSPACE
:
10360 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
10363 resolve_branch (code
->ext
.filepos
->err
, code
);
10367 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
10370 resolve_branch (code
->ext
.inquire
->err
, code
);
10373 case EXEC_IOLENGTH
:
10374 gcc_assert (code
->ext
.inquire
!= NULL
);
10375 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
10378 resolve_branch (code
->ext
.inquire
->err
, code
);
10382 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
10385 resolve_branch (code
->ext
.wait
->err
, code
);
10386 resolve_branch (code
->ext
.wait
->end
, code
);
10387 resolve_branch (code
->ext
.wait
->eor
, code
);
10392 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
10395 resolve_branch (code
->ext
.dt
->err
, code
);
10396 resolve_branch (code
->ext
.dt
->end
, code
);
10397 resolve_branch (code
->ext
.dt
->eor
, code
);
10400 case EXEC_TRANSFER
:
10401 resolve_transfer (code
);
10404 case EXEC_DO_CONCURRENT
:
10406 resolve_forall_iterators (code
->ext
.forall_iterator
);
10408 if (code
->expr1
!= NULL
10409 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
10410 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
10411 "expression", &code
->expr1
->where
);
10414 case EXEC_OMP_ATOMIC
:
10415 case EXEC_OMP_BARRIER
:
10416 case EXEC_OMP_CRITICAL
:
10417 case EXEC_OMP_FLUSH
:
10419 case EXEC_OMP_MASTER
:
10420 case EXEC_OMP_ORDERED
:
10421 case EXEC_OMP_SECTIONS
:
10422 case EXEC_OMP_SINGLE
:
10423 case EXEC_OMP_TASKWAIT
:
10424 case EXEC_OMP_TASKYIELD
:
10425 case EXEC_OMP_WORKSHARE
:
10426 gfc_resolve_omp_directive (code
, ns
);
10429 case EXEC_OMP_PARALLEL
:
10430 case EXEC_OMP_PARALLEL_DO
:
10431 case EXEC_OMP_PARALLEL_SECTIONS
:
10432 case EXEC_OMP_PARALLEL_WORKSHARE
:
10433 case EXEC_OMP_TASK
:
10434 omp_workshare_save
= omp_workshare_flag
;
10435 omp_workshare_flag
= 0;
10436 gfc_resolve_omp_directive (code
, ns
);
10437 omp_workshare_flag
= omp_workshare_save
;
10441 gfc_internal_error ("resolve_code(): Bad statement code");
10445 cs_base
= frame
.prev
;
10449 /* Resolve initial values and make sure they are compatible with
10453 resolve_values (gfc_symbol
*sym
)
10457 if (sym
->value
== NULL
)
10460 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
10461 t
= resolve_structure_cons (sym
->value
, 1);
10463 t
= gfc_resolve_expr (sym
->value
);
10468 gfc_check_assign_symbol (sym
, NULL
, sym
->value
);
10472 /* Verify the binding labels for common blocks that are BIND(C). The label
10473 for a BIND(C) common block must be identical in all scoping units in which
10474 the common block is declared. Further, the binding label can not collide
10475 with any other global entity in the program. */
10478 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
10480 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
10482 gfc_gsymbol
*binding_label_gsym
;
10483 gfc_gsymbol
*comm_name_gsym
;
10484 const char * bind_label
= comm_block_tree
->n
.common
->binding_label
10485 ? comm_block_tree
->n
.common
->binding_label
: "";
10487 /* See if a global symbol exists by the common block's name. It may
10488 be NULL if the common block is use-associated. */
10489 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
10490 comm_block_tree
->n
.common
->name
);
10491 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
10492 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
10493 "with the global entity '%s' at %L",
10495 comm_block_tree
->n
.common
->name
,
10496 &(comm_block_tree
->n
.common
->where
),
10497 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
10498 else if (comm_name_gsym
!= NULL
10499 && strcmp (comm_name_gsym
->name
,
10500 comm_block_tree
->n
.common
->name
) == 0)
10502 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
10504 if (comm_name_gsym
->binding_label
== NULL
)
10505 /* No binding label for common block stored yet; save this one. */
10506 comm_name_gsym
->binding_label
= bind_label
;
10507 else if (strcmp (comm_name_gsym
->binding_label
, bind_label
) != 0)
10509 /* Common block names match but binding labels do not. */
10510 gfc_error ("Binding label '%s' for common block '%s' at %L "
10511 "does not match the binding label '%s' for common "
10512 "block '%s' at %L",
10514 comm_block_tree
->n
.common
->name
,
10515 &(comm_block_tree
->n
.common
->where
),
10516 comm_name_gsym
->binding_label
,
10517 comm_name_gsym
->name
,
10518 &(comm_name_gsym
->where
));
10523 /* There is no binding label (NAME="") so we have nothing further to
10524 check and nothing to add as a global symbol for the label. */
10525 if (!comm_block_tree
->n
.common
->binding_label
)
10528 binding_label_gsym
=
10529 gfc_find_gsymbol (gfc_gsym_root
,
10530 comm_block_tree
->n
.common
->binding_label
);
10531 if (binding_label_gsym
== NULL
)
10533 /* Need to make a global symbol for the binding label to prevent
10534 it from colliding with another. */
10535 binding_label_gsym
=
10536 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
10537 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
10538 binding_label_gsym
->type
= GSYM_COMMON
;
10542 /* If comm_name_gsym is NULL, the name common block is use
10543 associated and the name could be colliding. */
10544 if (binding_label_gsym
->type
!= GSYM_COMMON
)
10545 gfc_error ("Binding label '%s' for common block '%s' at %L "
10546 "collides with the global entity '%s' at %L",
10547 comm_block_tree
->n
.common
->binding_label
,
10548 comm_block_tree
->n
.common
->name
,
10549 &(comm_block_tree
->n
.common
->where
),
10550 binding_label_gsym
->name
,
10551 &(binding_label_gsym
->where
));
10552 else if (comm_name_gsym
!= NULL
10553 && (strcmp (binding_label_gsym
->name
,
10554 comm_name_gsym
->binding_label
) != 0)
10555 && (strcmp (binding_label_gsym
->sym_name
,
10556 comm_name_gsym
->name
) != 0))
10557 gfc_error ("Binding label '%s' for common block '%s' at %L "
10558 "collides with global entity '%s' at %L",
10559 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
10560 &(comm_block_tree
->n
.common
->where
),
10561 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
10569 /* Verify any BIND(C) derived types in the namespace so we can report errors
10570 for them once, rather than for each variable declared of that type. */
10573 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10575 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10576 && derived_sym
->attr
.is_bind_c
== 1)
10577 verify_bind_c_derived_type (derived_sym
);
10583 /* Verify that any binding labels used in a given namespace do not collide
10584 with the names or binding labels of any global symbols. */
10587 gfc_verify_binding_labels (gfc_symbol
*sym
)
10591 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
10592 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
)
10594 gfc_gsymbol
*bind_c_sym
;
10596 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10597 if (bind_c_sym
!= NULL
10598 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
10600 if (sym
->attr
.if_source
== IFSRC_DECL
10601 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
10602 && bind_c_sym
->type
!= GSYM_FUNCTION
)
10603 && ((sym
->attr
.contained
== 1
10604 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
10605 || (sym
->attr
.use_assoc
== 1
10606 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
10608 /* Make sure global procedures don't collide with anything. */
10609 gfc_error ("Binding label '%s' at %L collides with the global "
10610 "entity '%s' at %L", sym
->binding_label
,
10611 &(sym
->declared_at
), bind_c_sym
->name
,
10612 &(bind_c_sym
->where
));
10615 else if (sym
->attr
.contained
== 0
10616 && (sym
->attr
.if_source
== IFSRC_IFBODY
10617 && sym
->attr
.flavor
== FL_PROCEDURE
)
10618 && (bind_c_sym
->sym_name
!= NULL
10619 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
10621 /* Make sure procedures in interface bodies don't collide. */
10622 gfc_error ("Binding label '%s' in interface body at %L collides "
10623 "with the global entity '%s' at %L",
10624 sym
->binding_label
,
10625 &(sym
->declared_at
), bind_c_sym
->name
,
10626 &(bind_c_sym
->where
));
10629 else if (sym
->attr
.contained
== 0
10630 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
10631 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
10632 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
10633 || sym
->attr
.use_assoc
== 0)
10635 gfc_error ("Binding label '%s' at %L collides with global "
10636 "entity '%s' at %L", sym
->binding_label
,
10637 &(sym
->declared_at
), bind_c_sym
->name
,
10638 &(bind_c_sym
->where
));
10642 if (has_error
!= 0)
10643 /* Clear the binding label to prevent checking multiple times. */
10644 sym
->binding_label
= NULL
;
10646 else if (bind_c_sym
== NULL
)
10648 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
10649 bind_c_sym
->where
= sym
->declared_at
;
10650 bind_c_sym
->sym_name
= sym
->name
;
10652 if (sym
->attr
.use_assoc
== 1)
10653 bind_c_sym
->mod_name
= sym
->module
;
10655 if (sym
->ns
->proc_name
!= NULL
)
10656 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
10658 if (sym
->attr
.contained
== 0)
10660 if (sym
->attr
.subroutine
)
10661 bind_c_sym
->type
= GSYM_SUBROUTINE
;
10662 else if (sym
->attr
.function
)
10663 bind_c_sym
->type
= GSYM_FUNCTION
;
10671 /* Resolve an index expression. */
10674 resolve_index_expr (gfc_expr
*e
)
10676 if (gfc_resolve_expr (e
) == FAILURE
)
10679 if (gfc_simplify_expr (e
, 0) == FAILURE
)
10682 if (gfc_specification_expr (e
) == FAILURE
)
10689 /* Resolve a charlen structure. */
10692 resolve_charlen (gfc_charlen
*cl
)
10695 bool saved_specification_expr
;
10701 saved_specification_expr
= specification_expr
;
10702 specification_expr
= true;
10704 if (cl
->length_from_typespec
)
10706 if (gfc_resolve_expr (cl
->length
) == FAILURE
)
10708 specification_expr
= saved_specification_expr
;
10712 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
10714 specification_expr
= saved_specification_expr
;
10721 if (resolve_index_expr (cl
->length
) == FAILURE
)
10723 specification_expr
= saved_specification_expr
;
10728 /* "If the character length parameter value evaluates to a negative
10729 value, the length of character entities declared is zero." */
10730 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10732 if (gfc_option
.warn_surprising
)
10733 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10734 " the length has been set to zero",
10735 &cl
->length
->where
, i
);
10736 gfc_replace_expr (cl
->length
,
10737 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10740 /* Check that the character length is not too large. */
10741 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10742 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10743 && cl
->length
->ts
.type
== BT_INTEGER
10744 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10746 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10747 specification_expr
= saved_specification_expr
;
10751 specification_expr
= saved_specification_expr
;
10756 /* Test for non-constant shape arrays. */
10759 is_non_constant_shape_array (gfc_symbol
*sym
)
10765 not_constant
= false;
10766 if (sym
->as
!= NULL
)
10768 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10769 has not been simplified; parameter array references. Do the
10770 simplification now. */
10771 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10773 e
= sym
->as
->lower
[i
];
10774 if (e
&& (resolve_index_expr (e
) == FAILURE
10775 || !gfc_is_constant_expr (e
)))
10776 not_constant
= true;
10777 e
= sym
->as
->upper
[i
];
10778 if (e
&& (resolve_index_expr (e
) == FAILURE
10779 || !gfc_is_constant_expr (e
)))
10780 not_constant
= true;
10783 return not_constant
;
10786 /* Given a symbol and an initialization expression, add code to initialize
10787 the symbol to the function entry. */
10789 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10793 gfc_namespace
*ns
= sym
->ns
;
10795 /* Search for the function namespace if this is a contained
10796 function without an explicit result. */
10797 if (sym
->attr
.function
&& sym
== sym
->result
10798 && sym
->name
!= sym
->ns
->proc_name
->name
)
10800 ns
= ns
->contained
;
10801 for (;ns
; ns
= ns
->sibling
)
10802 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10808 gfc_free_expr (init
);
10812 /* Build an l-value expression for the result. */
10813 lval
= gfc_lval_expr_from_sym (sym
);
10815 /* Add the code at scope entry. */
10816 init_st
= gfc_get_code ();
10817 init_st
->next
= ns
->code
;
10818 ns
->code
= init_st
;
10820 /* Assign the default initializer to the l-value. */
10821 init_st
->loc
= sym
->declared_at
;
10822 init_st
->op
= EXEC_INIT_ASSIGN
;
10823 init_st
->expr1
= lval
;
10824 init_st
->expr2
= init
;
10827 /* Assign the default initializer to a derived type variable or result. */
10830 apply_default_init (gfc_symbol
*sym
)
10832 gfc_expr
*init
= NULL
;
10834 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10837 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10838 init
= gfc_default_initializer (&sym
->ts
);
10840 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10843 build_init_assign (sym
, init
);
10844 sym
->attr
.referenced
= 1;
10847 /* Build an initializer for a local integer, real, complex, logical, or
10848 character variable, based on the command line flags finit-local-zero,
10849 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10850 null if the symbol should not have a default initialization. */
10852 build_default_init_expr (gfc_symbol
*sym
)
10855 gfc_expr
*init_expr
;
10858 /* These symbols should never have a default initialization. */
10859 if (sym
->attr
.allocatable
10860 || sym
->attr
.external
10862 || sym
->attr
.pointer
10863 || sym
->attr
.in_equivalence
10864 || sym
->attr
.in_common
10867 || sym
->attr
.cray_pointee
10868 || sym
->attr
.cray_pointer
10872 /* Now we'll try to build an initializer expression. */
10873 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10874 &sym
->declared_at
);
10876 /* We will only initialize integers, reals, complex, logicals, and
10877 characters, and only if the corresponding command-line flags
10878 were set. Otherwise, we free init_expr and return null. */
10879 switch (sym
->ts
.type
)
10882 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10883 mpz_set_si (init_expr
->value
.integer
,
10884 gfc_option
.flag_init_integer_value
);
10887 gfc_free_expr (init_expr
);
10893 switch (gfc_option
.flag_init_real
)
10895 case GFC_INIT_REAL_SNAN
:
10896 init_expr
->is_snan
= 1;
10897 /* Fall through. */
10898 case GFC_INIT_REAL_NAN
:
10899 mpfr_set_nan (init_expr
->value
.real
);
10902 case GFC_INIT_REAL_INF
:
10903 mpfr_set_inf (init_expr
->value
.real
, 1);
10906 case GFC_INIT_REAL_NEG_INF
:
10907 mpfr_set_inf (init_expr
->value
.real
, -1);
10910 case GFC_INIT_REAL_ZERO
:
10911 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10915 gfc_free_expr (init_expr
);
10922 switch (gfc_option
.flag_init_real
)
10924 case GFC_INIT_REAL_SNAN
:
10925 init_expr
->is_snan
= 1;
10926 /* Fall through. */
10927 case GFC_INIT_REAL_NAN
:
10928 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10929 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10932 case GFC_INIT_REAL_INF
:
10933 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10934 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10937 case GFC_INIT_REAL_NEG_INF
:
10938 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10939 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10942 case GFC_INIT_REAL_ZERO
:
10943 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10947 gfc_free_expr (init_expr
);
10954 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10955 init_expr
->value
.logical
= 0;
10956 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10957 init_expr
->value
.logical
= 1;
10960 gfc_free_expr (init_expr
);
10966 /* For characters, the length must be constant in order to
10967 create a default initializer. */
10968 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10969 && sym
->ts
.u
.cl
->length
10970 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10972 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10973 init_expr
->value
.character
.length
= char_len
;
10974 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10975 for (i
= 0; i
< char_len
; i
++)
10976 init_expr
->value
.character
.string
[i
]
10977 = (unsigned char) gfc_option
.flag_init_character_value
;
10981 gfc_free_expr (init_expr
);
10984 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10985 && sym
->ts
.u
.cl
->length
)
10987 gfc_actual_arglist
*arg
;
10988 init_expr
= gfc_get_expr ();
10989 init_expr
->where
= sym
->declared_at
;
10990 init_expr
->ts
= sym
->ts
;
10991 init_expr
->expr_type
= EXPR_FUNCTION
;
10992 init_expr
->value
.function
.isym
=
10993 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10994 init_expr
->value
.function
.name
= "repeat";
10995 arg
= gfc_get_actual_arglist ();
10996 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10998 arg
->expr
->value
.character
.string
[0]
10999 = gfc_option
.flag_init_character_value
;
11000 arg
->next
= gfc_get_actual_arglist ();
11001 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
11002 init_expr
->value
.function
.actual
= arg
;
11007 gfc_free_expr (init_expr
);
11013 /* Add an initialization expression to a local variable. */
11015 apply_default_init_local (gfc_symbol
*sym
)
11017 gfc_expr
*init
= NULL
;
11019 /* The symbol should be a variable or a function return value. */
11020 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
11021 || (sym
->attr
.function
&& sym
->result
!= sym
))
11024 /* Try to build the initializer expression. If we can't initialize
11025 this symbol, then init will be NULL. */
11026 init
= build_default_init_expr (sym
);
11030 /* For saved variables, we don't want to add an initializer at function
11031 entry, so we just add a static initializer. Note that automatic variables
11032 are stack allocated even with -fno-automatic. */
11033 if (sym
->attr
.save
|| sym
->ns
->save_all
11034 || (gfc_option
.flag_max_stack_var_size
== 0
11035 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
11037 /* Don't clobber an existing initializer! */
11038 gcc_assert (sym
->value
== NULL
);
11043 build_init_assign (sym
, init
);
11047 /* Resolution of common features of flavors variable and procedure. */
11050 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
11052 gfc_array_spec
*as
;
11054 /* Avoid double diagnostics for function result symbols. */
11055 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
11056 && (sym
->ns
!= gfc_current_ns
))
11059 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11060 as
= CLASS_DATA (sym
)->as
;
11064 /* Constraints on deferred shape variable. */
11065 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
11067 bool pointer
, allocatable
, dimension
;
11069 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
11071 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
11072 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
11073 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
11077 pointer
= sym
->attr
.pointer
&& !sym
->attr
.select_type_temporary
;
11078 allocatable
= sym
->attr
.allocatable
;
11079 dimension
= sym
->attr
.dimension
;
11084 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11086 gfc_error ("Allocatable array '%s' at %L must have a deferred "
11087 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
11090 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object "
11091 "'%s' at %L may not be ALLOCATABLE",
11092 sym
->name
, &sym
->declared_at
) == FAILURE
)
11096 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
11098 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
11099 "assumed rank", sym
->name
, &sym
->declared_at
);
11105 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
11106 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
11108 gfc_error ("Array '%s' at %L cannot have a deferred shape",
11109 sym
->name
, &sym
->declared_at
);
11114 /* Constraints on polymorphic variables. */
11115 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
11118 if (sym
->attr
.class_ok
11119 && !sym
->attr
.select_type_temporary
11120 && !UNLIMITED_POLY(sym
)
11121 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
11123 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
11124 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
11125 &sym
->declared_at
);
11130 /* Assume that use associated symbols were checked in the module ns.
11131 Class-variables that are associate-names are also something special
11132 and excepted from the test. */
11133 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
11135 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
11136 "or pointer", sym
->name
, &sym
->declared_at
);
11145 /* Additional checks for symbols with flavor variable and derived
11146 type. To be called from resolve_fl_variable. */
11149 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
11151 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
11153 /* Check to see if a derived type is blocked from being host
11154 associated by the presence of another class I symbol in the same
11155 namespace. 14.6.1.3 of the standard and the discussion on
11156 comp.lang.fortran. */
11157 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
11158 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
11161 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
11162 if (s
&& s
->attr
.generic
)
11163 s
= gfc_find_dt_in_generic (s
);
11164 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
11166 gfc_error ("The type '%s' cannot be host associated at %L "
11167 "because it is blocked by an incompatible object "
11168 "of the same name declared at %L",
11169 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
11175 /* 4th constraint in section 11.3: "If an object of a type for which
11176 component-initialization is specified (R429) appears in the
11177 specification-part of a module and does not have the ALLOCATABLE
11178 or POINTER attribute, the object shall have the SAVE attribute."
11180 The check for initializers is performed with
11181 gfc_has_default_initializer because gfc_default_initializer generates
11182 a hidden default for allocatable components. */
11183 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
11184 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11185 && !sym
->ns
->save_all
&& !sym
->attr
.save
11186 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
11187 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
11188 && gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for "
11189 "module variable '%s' at %L, needed due to "
11190 "the default initialization", sym
->name
,
11191 &sym
->declared_at
) == FAILURE
)
11194 /* Assign default initializer. */
11195 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
11196 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
11198 sym
->value
= gfc_default_initializer (&sym
->ts
);
11205 /* Resolve symbols with flavor variable. */
11208 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
11210 int no_init_flag
, automatic_flag
;
11212 const char *auto_save_msg
;
11213 bool saved_specification_expr
;
11215 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
11218 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
11221 /* Set this flag to check that variables are parameters of all entries.
11222 This check is effected by the call to gfc_resolve_expr through
11223 is_non_constant_shape_array. */
11224 saved_specification_expr
= specification_expr
;
11225 specification_expr
= true;
11227 if (sym
->ns
->proc_name
11228 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11229 || sym
->ns
->proc_name
->attr
.is_main_program
)
11230 && !sym
->attr
.use_assoc
11231 && !sym
->attr
.allocatable
11232 && !sym
->attr
.pointer
11233 && is_non_constant_shape_array (sym
))
11235 /* The shape of a main program or module array needs to be
11237 gfc_error ("The module or main program array '%s' at %L must "
11238 "have constant shape", sym
->name
, &sym
->declared_at
);
11239 specification_expr
= saved_specification_expr
;
11243 /* Constraints on deferred type parameter. */
11244 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
11246 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
11247 "requires either the pointer or allocatable attribute",
11248 sym
->name
, &sym
->declared_at
);
11249 specification_expr
= saved_specification_expr
;
11253 if (sym
->ts
.type
== BT_CHARACTER
)
11255 /* Make sure that character string variables with assumed length are
11256 dummy arguments. */
11257 e
= sym
->ts
.u
.cl
->length
;
11258 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
11259 && !sym
->ts
.deferred
&& !sym
->attr
.select_type_temporary
)
11261 gfc_error ("Entity with assumed character length at %L must be a "
11262 "dummy argument or a PARAMETER", &sym
->declared_at
);
11263 specification_expr
= saved_specification_expr
;
11267 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
11269 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11270 specification_expr
= saved_specification_expr
;
11274 if (!gfc_is_constant_expr (e
)
11275 && !(e
->expr_type
== EXPR_VARIABLE
11276 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
11278 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
11279 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
11280 || sym
->ns
->proc_name
->attr
.is_main_program
))
11282 gfc_error ("'%s' at %L must have constant character length "
11283 "in this context", sym
->name
, &sym
->declared_at
);
11284 specification_expr
= saved_specification_expr
;
11287 if (sym
->attr
.in_common
)
11289 gfc_error ("COMMON variable '%s' at %L must have constant "
11290 "character length", sym
->name
, &sym
->declared_at
);
11291 specification_expr
= saved_specification_expr
;
11297 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
11298 apply_default_init_local (sym
); /* Try to apply a default initialization. */
11300 /* Determine if the symbol may not have an initializer. */
11301 no_init_flag
= automatic_flag
= 0;
11302 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
11303 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
11305 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
11306 && is_non_constant_shape_array (sym
))
11308 no_init_flag
= automatic_flag
= 1;
11310 /* Also, they must not have the SAVE attribute.
11311 SAVE_IMPLICIT is checked below. */
11312 if (sym
->as
&& sym
->attr
.codimension
)
11314 int corank
= sym
->as
->corank
;
11315 sym
->as
->corank
= 0;
11316 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
11317 sym
->as
->corank
= corank
;
11319 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
11321 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
11322 specification_expr
= saved_specification_expr
;
11327 /* Ensure that any initializer is simplified. */
11329 gfc_simplify_expr (sym
->value
, 1);
11331 /* Reject illegal initializers. */
11332 if (!sym
->mark
&& sym
->value
)
11334 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
11335 && CLASS_DATA (sym
)->attr
.allocatable
))
11336 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
11337 sym
->name
, &sym
->declared_at
);
11338 else if (sym
->attr
.external
)
11339 gfc_error ("External '%s' at %L cannot have an initializer",
11340 sym
->name
, &sym
->declared_at
);
11341 else if (sym
->attr
.dummy
11342 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
11343 gfc_error ("Dummy '%s' at %L cannot have an initializer",
11344 sym
->name
, &sym
->declared_at
);
11345 else if (sym
->attr
.intrinsic
)
11346 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
11347 sym
->name
, &sym
->declared_at
);
11348 else if (sym
->attr
.result
)
11349 gfc_error ("Function result '%s' at %L cannot have an initializer",
11350 sym
->name
, &sym
->declared_at
);
11351 else if (automatic_flag
)
11352 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
11353 sym
->name
, &sym
->declared_at
);
11355 goto no_init_error
;
11356 specification_expr
= saved_specification_expr
;
11361 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
11363 gfc_try res
= resolve_fl_variable_derived (sym
, no_init_flag
);
11364 specification_expr
= saved_specification_expr
;
11368 specification_expr
= saved_specification_expr
;
11373 /* Resolve a procedure. */
11376 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
11378 gfc_formal_arglist
*arg
;
11380 if (sym
->attr
.function
11381 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
11384 if (sym
->ts
.type
== BT_CHARACTER
)
11386 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
11388 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
11389 && resolve_charlen (cl
) == FAILURE
)
11392 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
11393 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
11395 gfc_error ("Character-valued statement function '%s' at %L must "
11396 "have constant length", sym
->name
, &sym
->declared_at
);
11401 /* Ensure that derived type for are not of a private type. Internal
11402 module procedures are excluded by 2.2.3.3 - i.e., they are not
11403 externally accessible and can access all the objects accessible in
11405 if (!(sym
->ns
->parent
11406 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
11407 && gfc_check_symbol_access (sym
))
11409 gfc_interface
*iface
;
11411 for (arg
= gfc_sym_get_dummy_args (sym
); arg
; arg
= arg
->next
)
11414 && arg
->sym
->ts
.type
== BT_DERIVED
11415 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11416 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11417 && gfc_notify_std (GFC_STD_F2003
, "'%s' is of a "
11418 "PRIVATE type and cannot be a dummy argument"
11419 " of '%s', which is PUBLIC at %L",
11420 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
11423 /* Stop this message from recurring. */
11424 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11429 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11430 PRIVATE to the containing module. */
11431 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11433 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11436 && arg
->sym
->ts
.type
== BT_DERIVED
11437 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11438 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11439 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
11440 "'%s' in PUBLIC interface '%s' at %L "
11441 "takes dummy arguments of '%s' which is "
11442 "PRIVATE", iface
->sym
->name
, sym
->name
,
11443 &iface
->sym
->declared_at
,
11444 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
11446 /* Stop this message from recurring. */
11447 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11453 /* PUBLIC interfaces may expose PRIVATE procedures that take types
11454 PRIVATE to the containing module. */
11455 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
11457 for (arg
= gfc_sym_get_dummy_args (iface
->sym
); arg
; arg
= arg
->next
)
11460 && arg
->sym
->ts
.type
== BT_DERIVED
11461 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
11462 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
11463 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
11464 "'%s' in PUBLIC interface '%s' at %L "
11465 "takes dummy arguments of '%s' which is "
11466 "PRIVATE", iface
->sym
->name
, sym
->name
,
11467 &iface
->sym
->declared_at
,
11468 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
11470 /* Stop this message from recurring. */
11471 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
11478 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
11479 && !sym
->attr
.proc_pointer
)
11481 gfc_error ("Function '%s' at %L cannot have an initializer",
11482 sym
->name
, &sym
->declared_at
);
11486 /* An external symbol may not have an initializer because it is taken to be
11487 a procedure. Exception: Procedure Pointers. */
11488 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
11490 gfc_error ("External object '%s' at %L may not have an initializer",
11491 sym
->name
, &sym
->declared_at
);
11495 /* An elemental function is required to return a scalar 12.7.1 */
11496 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
11498 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
11499 "result", sym
->name
, &sym
->declared_at
);
11500 /* Reset so that the error only occurs once. */
11501 sym
->attr
.elemental
= 0;
11505 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11506 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11508 gfc_error ("Statement function '%s' at %L may not have pointer or "
11509 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11513 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11514 char-len-param shall not be array-valued, pointer-valued, recursive
11515 or pure. ....snip... A character value of * may only be used in the
11516 following ways: (i) Dummy arg of procedure - dummy associates with
11517 actual length; (ii) To declare a named constant; or (iii) External
11518 function - but length must be declared in calling scoping unit. */
11519 if (sym
->attr
.function
11520 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11521 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11523 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11524 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11526 if (sym
->as
&& sym
->as
->rank
)
11527 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11528 "array-valued", sym
->name
, &sym
->declared_at
);
11530 if (sym
->attr
.pointer
)
11531 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11532 "pointer-valued", sym
->name
, &sym
->declared_at
);
11534 if (sym
->attr
.pure
)
11535 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11536 "pure", sym
->name
, &sym
->declared_at
);
11538 if (sym
->attr
.recursive
)
11539 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11540 "recursive", sym
->name
, &sym
->declared_at
);
11545 /* Appendix B.2 of the standard. Contained functions give an
11546 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11547 character length is an F2003 feature. */
11548 if (!sym
->attr
.contained
11549 && gfc_current_form
!= FORM_FIXED
11550 && !sym
->ts
.deferred
)
11551 gfc_notify_std (GFC_STD_F95_OBS
,
11552 "CHARACTER(*) function '%s' at %L",
11553 sym
->name
, &sym
->declared_at
);
11556 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11558 gfc_formal_arglist
*curr_arg
;
11559 int has_non_interop_arg
= 0;
11561 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11562 sym
->common_block
) == FAILURE
)
11564 /* Clear these to prevent looking at them again if there was an
11566 sym
->attr
.is_bind_c
= 0;
11567 sym
->attr
.is_c_interop
= 0;
11568 sym
->ts
.is_c_interop
= 0;
11572 /* So far, no errors have been found. */
11573 sym
->attr
.is_c_interop
= 1;
11574 sym
->ts
.is_c_interop
= 1;
11577 curr_arg
= gfc_sym_get_dummy_args (sym
);
11578 while (curr_arg
!= NULL
)
11580 /* Skip implicitly typed dummy args here. */
11581 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11582 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
11583 /* If something is found to fail, record the fact so we
11584 can mark the symbol for the procedure as not being
11585 BIND(C) to try and prevent multiple errors being
11587 has_non_interop_arg
= 1;
11589 curr_arg
= curr_arg
->next
;
11592 /* See if any of the arguments were not interoperable and if so, clear
11593 the procedure symbol to prevent duplicate error messages. */
11594 if (has_non_interop_arg
!= 0)
11596 sym
->attr
.is_c_interop
= 0;
11597 sym
->ts
.is_c_interop
= 0;
11598 sym
->attr
.is_bind_c
= 0;
11602 if (!sym
->attr
.proc_pointer
)
11604 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11606 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11607 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11610 if (sym
->attr
.intent
)
11612 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11613 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11616 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11618 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11619 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11622 if (sym
->attr
.external
&& sym
->attr
.function
11623 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11624 || sym
->attr
.contained
))
11626 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11627 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11630 if (strcmp ("ppr@", sym
->name
) == 0)
11632 gfc_error ("Procedure pointer result '%s' at %L "
11633 "is missing the pointer attribute",
11634 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11643 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11644 been defined and we now know their defined arguments, check that they fulfill
11645 the requirements of the standard for procedures used as finalizers. */
11648 gfc_resolve_finalizers (gfc_symbol
* derived
)
11650 gfc_finalizer
* list
;
11651 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11652 gfc_try result
= SUCCESS
;
11653 bool seen_scalar
= false;
11655 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11658 /* Walk over the list of finalizer-procedures, check them, and if any one
11659 does not fit in with the standard's definition, print an error and remove
11660 it from the list. */
11661 prev_link
= &derived
->f2k_derived
->finalizers
;
11662 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11664 gfc_formal_arglist
*dummy_args
;
11669 /* Skip this finalizer if we already resolved it. */
11670 if (list
->proc_tree
)
11672 prev_link
= &(list
->next
);
11676 /* Check this exists and is a SUBROUTINE. */
11677 if (!list
->proc_sym
->attr
.subroutine
)
11679 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11680 list
->proc_sym
->name
, &list
->where
);
11684 /* We should have exactly one argument. */
11685 dummy_args
= gfc_sym_get_dummy_args (list
->proc_sym
);
11686 if (!dummy_args
|| dummy_args
->next
)
11688 gfc_error ("FINAL procedure at %L must have exactly one argument",
11692 arg
= dummy_args
->sym
;
11694 /* This argument must be of our type. */
11695 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11697 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11698 &arg
->declared_at
, derived
->name
);
11702 /* It must neither be a pointer nor allocatable nor optional. */
11703 if (arg
->attr
.pointer
)
11705 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11706 &arg
->declared_at
);
11709 if (arg
->attr
.allocatable
)
11711 gfc_error ("Argument of FINAL procedure at %L must not be"
11712 " ALLOCATABLE", &arg
->declared_at
);
11715 if (arg
->attr
.optional
)
11717 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11718 &arg
->declared_at
);
11722 /* It must not be INTENT(OUT). */
11723 if (arg
->attr
.intent
== INTENT_OUT
)
11725 gfc_error ("Argument of FINAL procedure at %L must not be"
11726 " INTENT(OUT)", &arg
->declared_at
);
11730 /* Warn if the procedure is non-scalar and not assumed shape. */
11731 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11732 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11733 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11734 " shape argument", &arg
->declared_at
);
11736 /* Check that it does not match in kind and rank with a FINAL procedure
11737 defined earlier. To really loop over the *earlier* declarations,
11738 we need to walk the tail of the list as new ones were pushed at the
11740 /* TODO: Handle kind parameters once they are implemented. */
11741 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11742 for (i
= list
->next
; i
; i
= i
->next
)
11744 gfc_formal_arglist
*dummy_args
;
11746 /* Argument list might be empty; that is an error signalled earlier,
11747 but we nevertheless continued resolving. */
11748 dummy_args
= gfc_sym_get_dummy_args (i
->proc_sym
);
11751 gfc_symbol
* i_arg
= dummy_args
->sym
;
11752 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11753 if (i_rank
== my_rank
)
11755 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11756 " rank (%d) as '%s'",
11757 list
->proc_sym
->name
, &list
->where
, my_rank
,
11758 i
->proc_sym
->name
);
11764 /* Is this the/a scalar finalizer procedure? */
11765 if (!arg
->as
|| arg
->as
->rank
== 0)
11766 seen_scalar
= true;
11768 /* Find the symtree for this procedure. */
11769 gcc_assert (!list
->proc_tree
);
11770 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11772 prev_link
= &list
->next
;
11775 /* Remove wrong nodes immediately from the list so we don't risk any
11776 troubles in the future when they might fail later expectations. */
11780 *prev_link
= list
->next
;
11781 gfc_free_finalizer (i
);
11784 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11785 were nodes in the list, must have been for arrays. It is surely a good
11786 idea to have a scalar version there if there's something to finalize. */
11787 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
11788 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11789 " defined at %L, suggest also scalar one",
11790 derived
->name
, &derived
->declared_at
);
11792 /* TODO: Remove this error when finalization is finished. */
11793 gfc_error ("Finalization at %L is not yet implemented",
11794 &derived
->declared_at
);
11796 gfc_find_derived_vtab (derived
);
11801 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11804 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11805 const char* generic_name
, locus where
)
11807 gfc_symbol
*sym1
, *sym2
;
11808 const char *pass1
, *pass2
;
11810 gcc_assert (t1
->specific
&& t2
->specific
);
11811 gcc_assert (!t1
->specific
->is_generic
);
11812 gcc_assert (!t2
->specific
->is_generic
);
11813 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11815 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11816 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11821 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11822 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11823 || sym1
->attr
.function
!= sym2
->attr
.function
)
11825 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11826 " GENERIC '%s' at %L",
11827 sym1
->name
, sym2
->name
, generic_name
, &where
);
11831 /* Compare the interfaces. */
11832 if (t1
->specific
->nopass
)
11834 else if (t1
->specific
->pass_arg
)
11835 pass1
= t1
->specific
->pass_arg
;
11837 pass1
= gfc_sym_get_dummy_args (t1
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11838 if (t2
->specific
->nopass
)
11840 else if (t2
->specific
->pass_arg
)
11841 pass2
= t2
->specific
->pass_arg
;
11843 pass2
= gfc_sym_get_dummy_args (t2
->specific
->u
.specific
->n
.sym
)->sym
->name
;
11844 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11845 NULL
, 0, pass1
, pass2
))
11847 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11848 sym1
->name
, sym2
->name
, generic_name
, &where
);
11856 /* Worker function for resolving a generic procedure binding; this is used to
11857 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11859 The difference between those cases is finding possible inherited bindings
11860 that are overridden, as one has to look for them in tb_sym_root,
11861 tb_uop_root or tb_op, respectively. Thus the caller must already find
11862 the super-type and set p->overridden correctly. */
11865 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11866 gfc_typebound_proc
* p
, const char* name
)
11868 gfc_tbp_generic
* target
;
11869 gfc_symtree
* first_target
;
11870 gfc_symtree
* inherited
;
11872 gcc_assert (p
&& p
->is_generic
);
11874 /* Try to find the specific bindings for the symtrees in our target-list. */
11875 gcc_assert (p
->u
.generic
);
11876 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11877 if (!target
->specific
)
11879 gfc_typebound_proc
* overridden_tbp
;
11880 gfc_tbp_generic
* g
;
11881 const char* target_name
;
11883 target_name
= target
->specific_st
->name
;
11885 /* Defined for this type directly. */
11886 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11888 target
->specific
= target
->specific_st
->n
.tb
;
11889 goto specific_found
;
11892 /* Look for an inherited specific binding. */
11895 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11900 gcc_assert (inherited
->n
.tb
);
11901 target
->specific
= inherited
->n
.tb
;
11902 goto specific_found
;
11906 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11907 " at %L", target_name
, name
, &p
->where
);
11910 /* Once we've found the specific binding, check it is not ambiguous with
11911 other specifics already found or inherited for the same GENERIC. */
11913 gcc_assert (target
->specific
);
11915 /* This must really be a specific binding! */
11916 if (target
->specific
->is_generic
)
11918 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11919 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11923 /* Check those already resolved on this type directly. */
11924 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11925 if (g
!= target
&& g
->specific
11926 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11930 /* Check for ambiguity with inherited specific targets. */
11931 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11932 overridden_tbp
= overridden_tbp
->overridden
)
11933 if (overridden_tbp
->is_generic
)
11935 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11937 gcc_assert (g
->specific
);
11938 if (check_generic_tbp_ambiguity (target
, g
,
11939 name
, p
->where
) == FAILURE
)
11945 /* If we attempt to "overwrite" a specific binding, this is an error. */
11946 if (p
->overridden
&& !p
->overridden
->is_generic
)
11948 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11949 " the same name", name
, &p
->where
);
11953 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11954 all must have the same attributes here. */
11955 first_target
= p
->u
.generic
->specific
->u
.specific
;
11956 gcc_assert (first_target
);
11957 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11958 p
->function
= first_target
->n
.sym
->attr
.function
;
11964 /* Resolve a GENERIC procedure binding for a derived type. */
11967 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11969 gfc_symbol
* super_type
;
11971 /* Find the overridden binding if any. */
11972 st
->n
.tb
->overridden
= NULL
;
11973 super_type
= gfc_get_derived_super_type (derived
);
11976 gfc_symtree
* overridden
;
11977 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11980 if (overridden
&& overridden
->n
.tb
)
11981 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11984 /* Resolve using worker function. */
11985 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11989 /* Retrieve the target-procedure of an operator binding and do some checks in
11990 common for intrinsic and user-defined type-bound operators. */
11993 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11995 gfc_symbol
* target_proc
;
11997 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11998 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11999 gcc_assert (target_proc
);
12001 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
12002 if (target
->specific
->nopass
)
12004 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
12008 return target_proc
;
12012 /* Resolve a type-bound intrinsic operator. */
12015 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
12016 gfc_typebound_proc
* p
)
12018 gfc_symbol
* super_type
;
12019 gfc_tbp_generic
* target
;
12021 /* If there's already an error here, do nothing (but don't fail again). */
12025 /* Operators should always be GENERIC bindings. */
12026 gcc_assert (p
->is_generic
);
12028 /* Look for an overridden binding. */
12029 super_type
= gfc_get_derived_super_type (derived
);
12030 if (super_type
&& super_type
->f2k_derived
)
12031 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
12034 p
->overridden
= NULL
;
12036 /* Resolve general GENERIC properties using worker function. */
12037 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
12040 /* Check the targets to be procedures of correct interface. */
12041 for (target
= p
->u
.generic
; target
; target
= target
->next
)
12043 gfc_symbol
* target_proc
;
12045 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
12049 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
12052 /* Add target to non-typebound operator list. */
12053 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
12054 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
12056 gfc_interface
*head
, *intr
;
12057 if (gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
,
12058 p
->where
) == FAILURE
)
12060 head
= derived
->ns
->op
[op
];
12061 intr
= gfc_get_interface ();
12062 intr
->sym
= target_proc
;
12063 intr
->where
= p
->where
;
12065 derived
->ns
->op
[op
] = intr
;
12077 /* Resolve a type-bound user operator (tree-walker callback). */
12079 static gfc_symbol
* resolve_bindings_derived
;
12080 static gfc_try resolve_bindings_result
;
12082 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
12085 resolve_typebound_user_op (gfc_symtree
* stree
)
12087 gfc_symbol
* super_type
;
12088 gfc_tbp_generic
* target
;
12090 gcc_assert (stree
&& stree
->n
.tb
);
12092 if (stree
->n
.tb
->error
)
12095 /* Operators should always be GENERIC bindings. */
12096 gcc_assert (stree
->n
.tb
->is_generic
);
12098 /* Find overridden procedure, if any. */
12099 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12100 if (super_type
&& super_type
->f2k_derived
)
12102 gfc_symtree
* overridden
;
12103 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
12104 stree
->name
, true, NULL
);
12106 if (overridden
&& overridden
->n
.tb
)
12107 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12110 stree
->n
.tb
->overridden
= NULL
;
12112 /* Resolve basically using worker function. */
12113 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
12117 /* Check the targets to be functions of correct interface. */
12118 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
12120 gfc_symbol
* target_proc
;
12122 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
12126 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
12133 resolve_bindings_result
= FAILURE
;
12134 stree
->n
.tb
->error
= 1;
12138 /* Resolve the type-bound procedures for a derived type. */
12141 resolve_typebound_procedure (gfc_symtree
* stree
)
12145 gfc_symbol
* me_arg
;
12146 gfc_symbol
* super_type
;
12147 gfc_component
* comp
;
12149 gcc_assert (stree
);
12151 /* Undefined specific symbol from GENERIC target definition. */
12155 if (stree
->n
.tb
->error
)
12158 /* If this is a GENERIC binding, use that routine. */
12159 if (stree
->n
.tb
->is_generic
)
12161 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
12167 /* Get the target-procedure to check it. */
12168 gcc_assert (!stree
->n
.tb
->is_generic
);
12169 gcc_assert (stree
->n
.tb
->u
.specific
);
12170 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
12171 where
= stree
->n
.tb
->where
;
12173 /* Default access should already be resolved from the parser. */
12174 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
12176 if (stree
->n
.tb
->deferred
)
12178 if (check_proc_interface (proc
, &where
) == FAILURE
)
12183 /* Check for F08:C465. */
12184 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
12185 || (proc
->attr
.proc
!= PROC_MODULE
12186 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
12187 || proc
->attr
.abstract
)
12189 gfc_error ("'%s' must be a module procedure or an external procedure with"
12190 " an explicit interface at %L", proc
->name
, &where
);
12195 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
12196 stree
->n
.tb
->function
= proc
->attr
.function
;
12198 /* Find the super-type of the current derived type. We could do this once and
12199 store in a global if speed is needed, but as long as not I believe this is
12200 more readable and clearer. */
12201 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
12203 /* If PASS, resolve and check arguments if not already resolved / loaded
12204 from a .mod file. */
12205 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
12207 gfc_formal_arglist
*dummy_args
;
12209 dummy_args
= gfc_sym_get_dummy_args (proc
);
12210 if (stree
->n
.tb
->pass_arg
)
12212 gfc_formal_arglist
*i
;
12214 /* If an explicit passing argument name is given, walk the arg-list
12215 and look for it. */
12218 stree
->n
.tb
->pass_arg_num
= 1;
12219 for (i
= dummy_args
; i
; i
= i
->next
)
12221 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
12226 ++stree
->n
.tb
->pass_arg_num
;
12231 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
12233 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
12234 stree
->n
.tb
->pass_arg
);
12240 /* Otherwise, take the first one; there should in fact be at least
12242 stree
->n
.tb
->pass_arg_num
= 1;
12245 gfc_error ("Procedure '%s' with PASS at %L must have at"
12246 " least one argument", proc
->name
, &where
);
12249 me_arg
= dummy_args
->sym
;
12252 /* Now check that the argument-type matches and the passed-object
12253 dummy argument is generally fine. */
12255 gcc_assert (me_arg
);
12257 if (me_arg
->ts
.type
!= BT_CLASS
)
12259 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12260 " at %L", proc
->name
, &where
);
12264 if (CLASS_DATA (me_arg
)->ts
.u
.derived
12265 != resolve_bindings_derived
)
12267 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12268 " the derived-type '%s'", me_arg
->name
, proc
->name
,
12269 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
12273 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
12274 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
12276 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
12277 " scalar", proc
->name
, &where
);
12280 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
12282 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12283 " be ALLOCATABLE", proc
->name
, &where
);
12286 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
12288 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
12289 " be POINTER", proc
->name
, &where
);
12294 /* If we are extending some type, check that we don't override a procedure
12295 flagged NON_OVERRIDABLE. */
12296 stree
->n
.tb
->overridden
= NULL
;
12299 gfc_symtree
* overridden
;
12300 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
12301 stree
->name
, true, NULL
);
12305 if (overridden
->n
.tb
)
12306 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
12308 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
12313 /* See if there's a name collision with a component directly in this type. */
12314 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
12315 if (!strcmp (comp
->name
, stree
->name
))
12317 gfc_error ("Procedure '%s' at %L has the same name as a component of"
12319 stree
->name
, &where
, resolve_bindings_derived
->name
);
12323 /* Try to find a name collision with an inherited component. */
12324 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
12326 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
12327 " component of '%s'",
12328 stree
->name
, &where
, resolve_bindings_derived
->name
);
12332 stree
->n
.tb
->error
= 0;
12336 resolve_bindings_result
= FAILURE
;
12337 stree
->n
.tb
->error
= 1;
12342 resolve_typebound_procedures (gfc_symbol
* derived
)
12345 gfc_symbol
* super_type
;
12347 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
12350 super_type
= gfc_get_derived_super_type (derived
);
12352 resolve_typebound_procedures (super_type
);
12354 resolve_bindings_derived
= derived
;
12355 resolve_bindings_result
= SUCCESS
;
12357 /* Make sure the vtab has been generated. */
12358 gfc_find_derived_vtab (derived
);
12360 if (derived
->f2k_derived
->tb_sym_root
)
12361 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
12362 &resolve_typebound_procedure
);
12364 if (derived
->f2k_derived
->tb_uop_root
)
12365 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
12366 &resolve_typebound_user_op
);
12368 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
12370 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
12371 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
12373 resolve_bindings_result
= FAILURE
;
12376 return resolve_bindings_result
;
12380 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
12381 to give all identical derived types the same backend_decl. */
12383 add_dt_to_dt_list (gfc_symbol
*derived
)
12385 gfc_dt_list
*dt_list
;
12387 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
12388 if (derived
== dt_list
->derived
)
12391 dt_list
= gfc_get_dt_list ();
12392 dt_list
->next
= gfc_derived_types
;
12393 dt_list
->derived
= derived
;
12394 gfc_derived_types
= dt_list
;
12398 /* Ensure that a derived-type is really not abstract, meaning that every
12399 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
12402 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
12407 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
12409 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
12412 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
12414 gfc_symtree
* overriding
;
12415 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
12418 gcc_assert (overriding
->n
.tb
);
12419 if (overriding
->n
.tb
->deferred
)
12421 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
12422 " '%s' is DEFERRED and not overridden",
12423 sub
->name
, &sub
->declared_at
, st
->name
);
12432 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
12434 /* The algorithm used here is to recursively travel up the ancestry of sub
12435 and for each ancestor-type, check all bindings. If any of them is
12436 DEFERRED, look it up starting from sub and see if the found (overriding)
12437 binding is not DEFERRED.
12438 This is not the most efficient way to do this, but it should be ok and is
12439 clearer than something sophisticated. */
12441 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
12443 if (!ancestor
->attr
.abstract
)
12446 /* Walk bindings of this ancestor. */
12447 if (ancestor
->f2k_derived
)
12450 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
12455 /* Find next ancestor type and recurse on it. */
12456 ancestor
= gfc_get_derived_super_type (ancestor
);
12458 return ensure_not_abstract (sub
, ancestor
);
12464 /* This check for typebound defined assignments is done recursively
12465 since the order in which derived types are resolved is not always in
12466 order of the declarations. */
12469 check_defined_assignments (gfc_symbol
*derived
)
12473 for (c
= derived
->components
; c
; c
= c
->next
)
12475 if (c
->ts
.type
!= BT_DERIVED
12477 || c
->attr
.allocatable
12478 || c
->attr
.proc_pointer_comp
12479 || c
->attr
.class_pointer
12480 || c
->attr
.proc_pointer
)
12483 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
12484 || (c
->ts
.u
.derived
->f2k_derived
12485 && c
->ts
.u
.derived
->f2k_derived
->tb_op
[INTRINSIC_ASSIGN
]))
12487 derived
->attr
.defined_assign_comp
= 1;
12491 check_defined_assignments (c
->ts
.u
.derived
);
12492 if (c
->ts
.u
.derived
->attr
.defined_assign_comp
)
12494 derived
->attr
.defined_assign_comp
= 1;
12501 /* Resolve the components of a derived type. This does not have to wait until
12502 resolution stage, but can be done as soon as the dt declaration has been
12506 resolve_fl_derived0 (gfc_symbol
*sym
)
12508 gfc_symbol
* super_type
;
12511 if (sym
->attr
.unlimited_polymorphic
)
12514 super_type
= gfc_get_derived_super_type (sym
);
12517 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
12519 gfc_error ("As extending type '%s' at %L has a coarray component, "
12520 "parent type '%s' shall also have one", sym
->name
,
12521 &sym
->declared_at
, super_type
->name
);
12525 /* Ensure the extended type gets resolved before we do. */
12526 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
12529 /* An ABSTRACT type must be extensible. */
12530 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
12532 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
12533 sym
->name
, &sym
->declared_at
);
12537 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
12540 for ( ; c
!= NULL
; c
= c
->next
)
12542 if (c
->attr
.artificial
)
12545 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
12546 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
12548 gfc_error ("Deferred-length character component '%s' at %L is not "
12549 "yet supported", c
->name
, &c
->loc
);
12554 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12555 && c
->attr
.codimension
12556 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12558 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12559 "deferred shape", c
->name
, &c
->loc
);
12564 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12565 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12567 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12568 "shall not be a coarray", c
->name
, &c
->loc
);
12573 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12574 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12575 || c
->attr
.allocatable
))
12577 gfc_error ("Component '%s' at %L with coarray component "
12578 "shall be a nonpointer, nonallocatable scalar",
12584 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12586 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12587 "is not an array pointer", c
->name
, &c
->loc
);
12591 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12593 gfc_symbol
*ifc
= c
->ts
.interface
;
12595 if (!sym
->attr
.vtype
12596 && check_proc_interface (ifc
, &c
->loc
) == FAILURE
)
12599 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12601 /* Resolve interface and copy attributes. */
12602 if (ifc
->formal
&& !ifc
->formal_ns
)
12603 resolve_symbol (ifc
);
12604 if (ifc
->attr
.intrinsic
)
12605 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12609 c
->ts
= ifc
->result
->ts
;
12610 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12611 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12612 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12613 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12614 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12619 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12620 c
->attr
.pointer
= ifc
->attr
.pointer
;
12621 c
->attr
.dimension
= ifc
->attr
.dimension
;
12622 c
->as
= gfc_copy_array_spec (ifc
->as
);
12623 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12625 c
->ts
.interface
= ifc
;
12626 c
->attr
.function
= ifc
->attr
.function
;
12627 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12629 c
->attr
.pure
= ifc
->attr
.pure
;
12630 c
->attr
.elemental
= ifc
->attr
.elemental
;
12631 c
->attr
.recursive
= ifc
->attr
.recursive
;
12632 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12633 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12634 /* Copy char length. */
12635 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12637 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12638 if (cl
->length
&& !cl
->resolved
12639 && gfc_resolve_expr (cl
->length
) == FAILURE
)
12645 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12647 /* Since PPCs are not implicitly typed, a PPC without an explicit
12648 interface must be a subroutine. */
12649 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12652 /* Procedure pointer components: Check PASS arg. */
12653 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12654 && !sym
->attr
.vtype
)
12656 gfc_symbol
* me_arg
;
12658 if (c
->tb
->pass_arg
)
12660 gfc_formal_arglist
* i
;
12662 /* If an explicit passing argument name is given, walk the arg-list
12663 and look for it. */
12666 c
->tb
->pass_arg_num
= 1;
12667 for (i
= c
->ts
.interface
->formal
; i
; i
= i
->next
)
12669 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12674 c
->tb
->pass_arg_num
++;
12679 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12680 "at %L has no argument '%s'", c
->name
,
12681 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12688 /* Otherwise, take the first one; there should in fact be at least
12690 c
->tb
->pass_arg_num
= 1;
12691 if (!c
->ts
.interface
->formal
)
12693 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12694 "must have at least one argument",
12699 me_arg
= c
->ts
.interface
->formal
->sym
;
12702 /* Now check that the argument-type matches. */
12703 gcc_assert (me_arg
);
12704 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12705 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12706 || (me_arg
->ts
.type
== BT_CLASS
12707 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12709 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12710 " the derived type '%s'", me_arg
->name
, c
->name
,
12711 me_arg
->name
, &c
->loc
, sym
->name
);
12716 /* Check for C453. */
12717 if (me_arg
->attr
.dimension
)
12719 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12720 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12726 if (me_arg
->attr
.pointer
)
12728 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12729 "may not have the POINTER attribute", me_arg
->name
,
12730 c
->name
, me_arg
->name
, &c
->loc
);
12735 if (me_arg
->attr
.allocatable
)
12737 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12738 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12739 me_arg
->name
, &c
->loc
);
12744 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12745 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12746 " at %L", c
->name
, &c
->loc
);
12750 /* Check type-spec if this is not the parent-type component. */
12751 if (((sym
->attr
.is_class
12752 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12753 || c
!= sym
->components
->ts
.u
.derived
->components
))
12754 || (!sym
->attr
.is_class
12755 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12756 && !sym
->attr
.vtype
12757 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
12760 /* If this type is an extension, set the accessibility of the parent
12763 && ((sym
->attr
.is_class
12764 && c
== sym
->components
->ts
.u
.derived
->components
)
12765 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12766 && strcmp (super_type
->name
, c
->name
) == 0)
12767 c
->attr
.access
= super_type
->attr
.access
;
12769 /* If this type is an extension, see if this component has the same name
12770 as an inherited type-bound procedure. */
12771 if (super_type
&& !sym
->attr
.is_class
12772 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12774 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12775 " inherited type-bound procedure",
12776 c
->name
, sym
->name
, &c
->loc
);
12780 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12781 && !c
->ts
.deferred
)
12783 if (c
->ts
.u
.cl
->length
== NULL
12784 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
12785 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12787 gfc_error ("Character length of component '%s' needs to "
12788 "be a constant specification expression at %L",
12790 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12795 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12796 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12798 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12799 "length must be a POINTER or ALLOCATABLE",
12800 c
->name
, sym
->name
, &c
->loc
);
12804 if (c
->ts
.type
== BT_DERIVED
12805 && sym
->component_access
!= ACCESS_PRIVATE
12806 && gfc_check_symbol_access (sym
)
12807 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12808 && !c
->ts
.u
.derived
->attr
.use_assoc
12809 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12810 && gfc_notify_std (GFC_STD_F2003
, "the component '%s' "
12811 "is a PRIVATE type and cannot be a component of "
12812 "'%s', which is PUBLIC at %L", c
->name
,
12813 sym
->name
, &sym
->declared_at
) == FAILURE
)
12816 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12818 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12819 "type %s", c
->name
, &c
->loc
, sym
->name
);
12823 if (sym
->attr
.sequence
)
12825 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12827 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12828 "not have the SEQUENCE attribute",
12829 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12834 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12835 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12836 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12837 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12838 CLASS_DATA (c
)->ts
.u
.derived
12839 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12841 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12842 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12843 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12845 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12846 "that has not been declared", c
->name
, sym
->name
,
12851 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12852 && CLASS_DATA (c
)->attr
.class_pointer
12853 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12854 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
12855 && !UNLIMITED_POLY (c
))
12857 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12858 "that has not been declared", c
->name
, sym
->name
,
12864 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12865 && (!c
->attr
.class_ok
12866 || !(CLASS_DATA (c
)->attr
.class_pointer
12867 || CLASS_DATA (c
)->attr
.allocatable
)))
12869 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12870 "or pointer", c
->name
, &c
->loc
);
12874 /* Ensure that all the derived type components are put on the
12875 derived type list; even in formal namespaces, where derived type
12876 pointer components might not have been declared. */
12877 if (c
->ts
.type
== BT_DERIVED
12879 && c
->ts
.u
.derived
->components
12881 && sym
!= c
->ts
.u
.derived
)
12882 add_dt_to_dt_list (c
->ts
.u
.derived
);
12884 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
12885 || c
->attr
.proc_pointer
12886 || c
->attr
.allocatable
)) == FAILURE
)
12889 if (c
->initializer
&& !sym
->attr
.vtype
12890 && gfc_check_assign_symbol (sym
, c
, c
->initializer
) == FAILURE
)
12894 check_defined_assignments (sym
);
12896 if (!sym
->attr
.defined_assign_comp
&& super_type
)
12897 sym
->attr
.defined_assign_comp
12898 = super_type
->attr
.defined_assign_comp
;
12900 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12901 all DEFERRED bindings are overridden. */
12902 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12903 && !sym
->attr
.is_class
12904 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
12907 /* Add derived type to the derived type list. */
12908 add_dt_to_dt_list (sym
);
12910 /* Check if the type is finalizable. This is done in order to ensure that the
12911 finalization wrapper is generated early enough. */
12912 gfc_is_finalizable (sym
, NULL
);
12918 /* The following procedure does the full resolution of a derived type,
12919 including resolution of all type-bound procedures (if present). In contrast
12920 to 'resolve_fl_derived0' this can only be done after the module has been
12921 parsed completely. */
12924 resolve_fl_derived (gfc_symbol
*sym
)
12926 gfc_symbol
*gen_dt
= NULL
;
12928 if (sym
->attr
.unlimited_polymorphic
)
12931 if (!sym
->attr
.is_class
)
12932 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12933 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12934 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12935 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12936 && gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of "
12937 "function '%s' at %L being the same name as derived "
12938 "type at %L", sym
->name
,
12939 gen_dt
->generic
->sym
== sym
12940 ? gen_dt
->generic
->next
->sym
->name
12941 : gen_dt
->generic
->sym
->name
,
12942 gen_dt
->generic
->sym
== sym
12943 ? &gen_dt
->generic
->next
->sym
->declared_at
12944 : &gen_dt
->generic
->sym
->declared_at
,
12945 &sym
->declared_at
) == FAILURE
)
12948 /* Resolve the finalizer procedures. */
12949 if (gfc_resolve_finalizers (sym
) == FAILURE
)
12952 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12954 /* Fix up incomplete CLASS symbols. */
12955 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12956 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12958 /* Nothing more to do for unlimited polymorphic entities. */
12959 if (data
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
12961 else if (vptr
->ts
.u
.derived
== NULL
)
12963 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12965 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12969 if (resolve_fl_derived0 (sym
) == FAILURE
)
12972 /* Resolve the type-bound procedures. */
12973 if (resolve_typebound_procedures (sym
) == FAILURE
)
12981 resolve_fl_namelist (gfc_symbol
*sym
)
12986 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12988 /* Check again, the check in match only works if NAMELIST comes
12990 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12992 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12993 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12997 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12998 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
12999 "object '%s' with assumed shape in namelist "
13000 "'%s' at %L", nl
->sym
->name
, sym
->name
,
13001 &sym
->declared_at
) == FAILURE
)
13004 if (is_non_constant_shape_array (nl
->sym
)
13005 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
13006 "object '%s' with nonconstant shape in namelist "
13007 "'%s' at %L", nl
->sym
->name
, sym
->name
,
13008 &sym
->declared_at
) == FAILURE
)
13011 if (nl
->sym
->ts
.type
== BT_CHARACTER
13012 && (nl
->sym
->ts
.u
.cl
->length
== NULL
13013 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
13014 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
13015 "'%s' with nonconstant character length in "
13016 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
13017 &sym
->declared_at
) == FAILURE
)
13020 /* FIXME: Once UDDTIO is implemented, the following can be
13022 if (nl
->sym
->ts
.type
== BT_CLASS
)
13024 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
13025 "polymorphic and requires a defined input/output "
13026 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13030 if (nl
->sym
->ts
.type
== BT_DERIVED
13031 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
13032 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
13034 if (gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
13035 "'%s' in namelist '%s' at %L with ALLOCATABLE "
13036 "or POINTER components", nl
->sym
->name
,
13037 sym
->name
, &sym
->declared_at
) == FAILURE
)
13040 /* FIXME: Once UDDTIO is implemented, the following can be
13042 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
13043 "ALLOCATABLE or POINTER components and thus requires "
13044 "a defined input/output procedure", nl
->sym
->name
,
13045 sym
->name
, &sym
->declared_at
);
13050 /* Reject PRIVATE objects in a PUBLIC namelist. */
13051 if (gfc_check_symbol_access (sym
))
13053 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13055 if (!nl
->sym
->attr
.use_assoc
13056 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
13057 && !gfc_check_symbol_access (nl
->sym
))
13059 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
13060 "cannot be member of PUBLIC namelist '%s' at %L",
13061 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13065 /* Types with private components that came here by USE-association. */
13066 if (nl
->sym
->ts
.type
== BT_DERIVED
13067 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
13069 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
13070 "components and cannot be member of namelist '%s' at %L",
13071 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13075 /* Types with private components that are defined in the same module. */
13076 if (nl
->sym
->ts
.type
== BT_DERIVED
13077 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
13078 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
13080 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
13081 "cannot be a member of PUBLIC namelist '%s' at %L",
13082 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
13089 /* 14.1.2 A module or internal procedure represent local entities
13090 of the same type as a namelist member and so are not allowed. */
13091 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
13093 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
13096 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
13097 if ((nl
->sym
== sym
->ns
->proc_name
)
13099 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
13104 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
13105 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
13107 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
13108 "attribute in '%s' at %L", nlsym
->name
,
13109 &sym
->declared_at
);
13119 resolve_fl_parameter (gfc_symbol
*sym
)
13121 /* A parameter array's shape needs to be constant. */
13122 if (sym
->as
!= NULL
13123 && (sym
->as
->type
== AS_DEFERRED
13124 || is_non_constant_shape_array (sym
)))
13126 gfc_error ("Parameter array '%s' at %L cannot be automatic "
13127 "or of deferred shape", sym
->name
, &sym
->declared_at
);
13131 /* Make sure a parameter that has been implicitly typed still
13132 matches the implicit type, since PARAMETER statements can precede
13133 IMPLICIT statements. */
13134 if (sym
->attr
.implicit_type
13135 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
13138 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
13139 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
13143 /* Make sure the types of derived parameters are consistent. This
13144 type checking is deferred until resolution because the type may
13145 refer to a derived type from the host. */
13146 if (sym
->ts
.type
== BT_DERIVED
13147 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
13149 gfc_error ("Incompatible derived type in PARAMETER at %L",
13150 &sym
->value
->where
);
13157 /* Do anything necessary to resolve a symbol. Right now, we just
13158 assume that an otherwise unknown symbol is a variable. This sort
13159 of thing commonly happens for symbols in module. */
13162 resolve_symbol (gfc_symbol
*sym
)
13164 int check_constant
, mp_flag
;
13165 gfc_symtree
*symtree
;
13166 gfc_symtree
*this_symtree
;
13169 symbol_attribute class_attr
;
13170 gfc_array_spec
*as
;
13171 bool saved_specification_expr
;
13173 if (sym
->attr
.artificial
)
13176 if (sym
->attr
.unlimited_polymorphic
)
13179 if (sym
->attr
.flavor
== FL_UNKNOWN
13180 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
13181 && !sym
->attr
.generic
&& !sym
->attr
.external
13182 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
13185 /* If we find that a flavorless symbol is an interface in one of the
13186 parent namespaces, find its symtree in this namespace, free the
13187 symbol and set the symtree to point to the interface symbol. */
13188 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
13190 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
13191 if (symtree
&& (symtree
->n
.sym
->generic
||
13192 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
13193 && sym
->ns
->construct_entities
)))
13195 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
13197 gfc_release_symbol (sym
);
13198 symtree
->n
.sym
->refs
++;
13199 this_symtree
->n
.sym
= symtree
->n
.sym
;
13204 /* Otherwise give it a flavor according to such attributes as
13206 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
13207 && sym
->attr
.intrinsic
== 0)
13208 sym
->attr
.flavor
= FL_VARIABLE
;
13209 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
13211 sym
->attr
.flavor
= FL_PROCEDURE
;
13212 if (sym
->attr
.dimension
)
13213 sym
->attr
.function
= 1;
13217 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
13218 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13220 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
13221 && resolve_procedure_interface (sym
) == FAILURE
)
13224 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
13225 && (sym
->attr
.procedure
|| sym
->attr
.external
))
13227 if (sym
->attr
.external
)
13228 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
13229 "at %L", &sym
->declared_at
);
13231 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
13232 "at %L", &sym
->declared_at
);
13237 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
13240 /* Symbols that are module procedures with results (functions) have
13241 the types and array specification copied for type checking in
13242 procedures that call them, as well as for saving to a module
13243 file. These symbols can't stand the scrutiny that their results
13245 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
13247 /* Make sure that the intrinsic is consistent with its internal
13248 representation. This needs to be done before assigning a default
13249 type to avoid spurious warnings. */
13250 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
13251 && gfc_resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
13254 /* Resolve associate names. */
13256 resolve_assoc_var (sym
, true);
13258 /* Assign default type to symbols that need one and don't have one. */
13259 if (sym
->ts
.type
== BT_UNKNOWN
)
13261 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
13263 gfc_set_default_type (sym
, 1, NULL
);
13266 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
13267 && !sym
->attr
.function
&& !sym
->attr
.subroutine
13268 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
13269 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
13271 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13273 /* The specific case of an external procedure should emit an error
13274 in the case that there is no implicit type. */
13276 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
13279 /* Result may be in another namespace. */
13280 resolve_symbol (sym
->result
);
13282 if (!sym
->result
->attr
.proc_pointer
)
13284 sym
->ts
= sym
->result
->ts
;
13285 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
13286 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
13287 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
13288 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
13289 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
13294 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
13296 bool saved_specification_expr
= specification_expr
;
13297 specification_expr
= true;
13298 gfc_resolve_array_spec (sym
->result
->as
, false);
13299 specification_expr
= saved_specification_expr
;
13302 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
13304 as
= CLASS_DATA (sym
)->as
;
13305 class_attr
= CLASS_DATA (sym
)->attr
;
13306 class_attr
.pointer
= class_attr
.class_pointer
;
13310 class_attr
= sym
->attr
;
13315 if (sym
->attr
.contiguous
13316 && (!class_attr
.dimension
13317 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
13318 && !class_attr
.pointer
)))
13320 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
13321 "array pointer or an assumed-shape or assumed-rank array",
13322 sym
->name
, &sym
->declared_at
);
13326 /* Assumed size arrays and assumed shape arrays must be dummy
13327 arguments. Array-spec's of implied-shape should have been resolved to
13328 AS_EXPLICIT already. */
13332 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
13333 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
13334 || as
->type
== AS_ASSUMED_SHAPE
)
13335 && !sym
->attr
.dummy
&& !sym
->attr
.select_type_temporary
)
13337 if (as
->type
== AS_ASSUMED_SIZE
)
13338 gfc_error ("Assumed size array at %L must be a dummy argument",
13339 &sym
->declared_at
);
13341 gfc_error ("Assumed shape array at %L must be a dummy argument",
13342 &sym
->declared_at
);
13345 /* TS 29113, C535a. */
13346 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
13347 && !sym
->attr
.select_type_temporary
)
13349 gfc_error ("Assumed-rank array at %L must be a dummy argument",
13350 &sym
->declared_at
);
13353 if (as
->type
== AS_ASSUMED_RANK
13354 && (sym
->attr
.codimension
|| sym
->attr
.value
))
13356 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
13357 "CODIMENSION attribute", &sym
->declared_at
);
13362 /* Make sure symbols with known intent or optional are really dummy
13363 variable. Because of ENTRY statement, this has to be deferred
13364 until resolution time. */
13366 if (!sym
->attr
.dummy
13367 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
13369 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
13373 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
13375 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
13376 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
13380 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
13382 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
13383 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
13385 gfc_error ("Character dummy variable '%s' at %L with VALUE "
13386 "attribute must have constant length",
13387 sym
->name
, &sym
->declared_at
);
13391 if (sym
->ts
.is_c_interop
13392 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
13394 gfc_error ("C interoperable character dummy variable '%s' at %L "
13395 "with VALUE attribute must have length one",
13396 sym
->name
, &sym
->declared_at
);
13401 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13402 && sym
->ts
.u
.derived
->attr
.generic
)
13404 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
13405 if (!sym
->ts
.u
.derived
)
13407 gfc_error ("The derived type '%s' at %L is of type '%s', "
13408 "which has not been defined", sym
->name
,
13409 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13410 sym
->ts
.type
= BT_UNKNOWN
;
13415 if (sym
->ts
.type
== BT_ASSUMED
)
13417 /* TS 29113, C407a. */
13418 if (!sym
->attr
.dummy
)
13420 gfc_error ("Assumed type of variable %s at %L is only permitted "
13421 "for dummy variables", sym
->name
, &sym
->declared_at
);
13424 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
13425 || sym
->attr
.pointer
|| sym
->attr
.value
)
13427 gfc_error ("Assumed-type variable %s at %L may not have the "
13428 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
13429 sym
->name
, &sym
->declared_at
);
13432 if (sym
->attr
.intent
== INTENT_OUT
)
13434 gfc_error ("Assumed-type variable %s at %L may not have the "
13435 "INTENT(OUT) attribute",
13436 sym
->name
, &sym
->declared_at
);
13439 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
13441 gfc_error ("Assumed-type variable %s at %L shall not be an "
13442 "explicit-shape array", sym
->name
, &sym
->declared_at
);
13447 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
13448 do this for something that was implicitly typed because that is handled
13449 in gfc_set_default_type. Handle dummy arguments and procedure
13450 definitions separately. Also, anything that is use associated is not
13451 handled here but instead is handled in the module it is declared in.
13452 Finally, derived type definitions are allowed to be BIND(C) since that
13453 only implies that they're interoperable, and they are checked fully for
13454 interoperability when a variable is declared of that type. */
13455 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
13456 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
13457 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
13459 gfc_try t
= SUCCESS
;
13461 /* First, make sure the variable is declared at the
13462 module-level scope (J3/04-007, Section 15.3). */
13463 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
13464 sym
->attr
.in_common
== 0)
13466 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
13467 "is neither a COMMON block nor declared at the "
13468 "module level scope", sym
->name
, &(sym
->declared_at
));
13471 else if (sym
->common_head
!= NULL
)
13473 t
= verify_com_block_vars_c_interop (sym
->common_head
);
13477 /* If type() declaration, we need to verify that the components
13478 of the given type are all C interoperable, etc. */
13479 if (sym
->ts
.type
== BT_DERIVED
&&
13480 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
13482 /* Make sure the user marked the derived type as BIND(C). If
13483 not, call the verify routine. This could print an error
13484 for the derived type more than once if multiple variables
13485 of that type are declared. */
13486 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
13487 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
13491 /* Verify the variable itself as C interoperable if it
13492 is BIND(C). It is not possible for this to succeed if
13493 the verify_bind_c_derived_type failed, so don't have to handle
13494 any error returned by verify_bind_c_derived_type. */
13495 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
13496 sym
->common_block
);
13501 /* clear the is_bind_c flag to prevent reporting errors more than
13502 once if something failed. */
13503 sym
->attr
.is_bind_c
= 0;
13508 /* If a derived type symbol has reached this point, without its
13509 type being declared, we have an error. Notice that most
13510 conditions that produce undefined derived types have already
13511 been dealt with. However, the likes of:
13512 implicit type(t) (t) ..... call foo (t) will get us here if
13513 the type is not declared in the scope of the implicit
13514 statement. Change the type to BT_UNKNOWN, both because it is so
13515 and to prevent an ICE. */
13516 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
13517 && sym
->ts
.u
.derived
->components
== NULL
13518 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
13520 gfc_error ("The derived type '%s' at %L is of type '%s', "
13521 "which has not been defined", sym
->name
,
13522 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13523 sym
->ts
.type
= BT_UNKNOWN
;
13527 /* Make sure that the derived type has been resolved and that the
13528 derived type is visible in the symbol's namespace, if it is a
13529 module function and is not PRIVATE. */
13530 if (sym
->ts
.type
== BT_DERIVED
13531 && sym
->ts
.u
.derived
->attr
.use_assoc
13532 && sym
->ns
->proc_name
13533 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13534 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
13537 /* Unless the derived-type declaration is use associated, Fortran 95
13538 does not allow public entries of private derived types.
13539 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
13540 161 in 95-006r3. */
13541 if (sym
->ts
.type
== BT_DERIVED
13542 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13543 && !sym
->ts
.u
.derived
->attr
.use_assoc
13544 && gfc_check_symbol_access (sym
)
13545 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13546 && gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L "
13547 "of PRIVATE derived type '%s'",
13548 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
13549 : "variable", sym
->name
, &sym
->declared_at
,
13550 sym
->ts
.u
.derived
->name
) == FAILURE
)
13553 /* F2008, C1302. */
13554 if (sym
->ts
.type
== BT_DERIVED
13555 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
13556 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
13557 || sym
->ts
.u
.derived
->attr
.lock_comp
)
13558 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
13560 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
13561 "type LOCK_TYPE must be a coarray", sym
->name
,
13562 &sym
->declared_at
);
13566 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13567 default initialization is defined (5.1.2.4.4). */
13568 if (sym
->ts
.type
== BT_DERIVED
13570 && sym
->attr
.intent
== INTENT_OUT
13572 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13574 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13576 if (c
->initializer
)
13578 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13579 "ASSUMED SIZE and so cannot have a default initializer",
13580 sym
->name
, &sym
->declared_at
);
13587 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13588 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13590 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13591 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13596 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13597 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13598 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13599 || class_attr
.codimension
)
13600 && (sym
->attr
.result
|| sym
->result
== sym
))
13602 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13603 "a coarray component", sym
->name
, &sym
->declared_at
);
13608 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13609 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13611 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13612 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13617 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13618 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13619 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13620 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13621 || class_attr
.allocatable
))
13623 gfc_error ("Variable '%s' at %L with coarray component "
13624 "shall be a nonpointer, nonallocatable scalar",
13625 sym
->name
, &sym
->declared_at
);
13629 /* F2008, C526. The function-result case was handled above. */
13630 if (class_attr
.codimension
13631 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13632 || sym
->attr
.select_type_temporary
13633 || sym
->ns
->save_all
13634 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13635 || sym
->ns
->proc_name
->attr
.is_main_program
13636 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13638 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13639 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13643 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13644 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13646 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13647 "deferred shape", sym
->name
, &sym
->declared_at
);
13650 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13651 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13653 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13654 "deferred shape", sym
->name
, &sym
->declared_at
);
13659 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13660 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13661 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13662 || (class_attr
.codimension
&& class_attr
.allocatable
))
13663 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13665 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13666 "allocatable coarray or have coarray components",
13667 sym
->name
, &sym
->declared_at
);
13671 if (class_attr
.codimension
&& sym
->attr
.dummy
13672 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13674 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13675 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13676 sym
->ns
->proc_name
->name
);
13680 if (sym
->ts
.type
== BT_LOGICAL
13681 && ((sym
->attr
.function
&& sym
->attr
.is_bind_c
&& sym
->result
== sym
)
13682 || ((sym
->attr
.dummy
|| sym
->attr
.result
) && sym
->ns
->proc_name
13683 && sym
->ns
->proc_name
->attr
.is_bind_c
)))
13686 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
13687 if (gfc_logical_kinds
[i
].kind
== sym
->ts
.kind
)
13689 if (!gfc_logical_kinds
[i
].c_bool
&& sym
->attr
.dummy
13690 && gfc_notify_std (GFC_STD_GNU
, "LOGICAL dummy argument '%s' at %L "
13691 "with non-C_Bool kind in BIND(C) procedure '%s'",
13692 sym
->name
, &sym
->declared_at
,
13693 sym
->ns
->proc_name
->name
) == FAILURE
)
13695 else if (!gfc_logical_kinds
[i
].c_bool
13696 && gfc_notify_std (GFC_STD_GNU
, "LOGICAL result variable '%s' at"
13697 " %L with non-C_Bool kind in BIND(C) "
13698 "procedure '%s'", sym
->name
,
13700 sym
->attr
.function
? sym
->name
13701 : sym
->ns
->proc_name
->name
)
13706 switch (sym
->attr
.flavor
)
13709 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
13714 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
13719 if (resolve_fl_namelist (sym
) == FAILURE
)
13724 if (resolve_fl_parameter (sym
) == FAILURE
)
13732 /* Resolve array specifier. Check as well some constraints
13733 on COMMON blocks. */
13735 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13737 /* Set the formal_arg_flag so that check_conflict will not throw
13738 an error for host associated variables in the specification
13739 expression for an array_valued function. */
13740 if (sym
->attr
.function
&& sym
->as
)
13741 formal_arg_flag
= 1;
13743 saved_specification_expr
= specification_expr
;
13744 specification_expr
= true;
13745 gfc_resolve_array_spec (sym
->as
, check_constant
);
13746 specification_expr
= saved_specification_expr
;
13748 formal_arg_flag
= 0;
13750 /* Resolve formal namespaces. */
13751 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13752 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13753 gfc_resolve (sym
->formal_ns
);
13755 /* Make sure the formal namespace is present. */
13756 if (sym
->formal
&& !sym
->formal_ns
)
13758 gfc_formal_arglist
*formal
= sym
->formal
;
13759 while (formal
&& !formal
->sym
)
13760 formal
= formal
->next
;
13764 sym
->formal_ns
= formal
->sym
->ns
;
13765 if (sym
->ns
!= formal
->sym
->ns
)
13766 sym
->formal_ns
->refs
++;
13770 /* Check threadprivate restrictions. */
13771 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13772 && (!sym
->attr
.in_common
13773 && sym
->module
== NULL
13774 && (sym
->ns
->proc_name
== NULL
13775 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13776 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13778 /* If we have come this far we can apply default-initializers, as
13779 described in 14.7.5, to those variables that have not already
13780 been assigned one. */
13781 if (sym
->ts
.type
== BT_DERIVED
13782 && sym
->ns
== gfc_current_ns
13784 && !sym
->attr
.allocatable
13785 && !sym
->attr
.alloc_comp
)
13787 symbol_attribute
*a
= &sym
->attr
;
13789 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13790 && !a
->in_common
&& !a
->use_assoc
13791 && (a
->referenced
|| a
->result
)
13792 && !(a
->function
&& sym
!= sym
->result
))
13793 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13794 apply_default_init (sym
);
13797 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13798 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13799 && !CLASS_DATA (sym
)->attr
.class_pointer
13800 && !CLASS_DATA (sym
)->attr
.allocatable
)
13801 apply_default_init (sym
);
13803 /* If this symbol has a type-spec, check it. */
13804 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13805 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13806 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
13812 /************* Resolve DATA statements *************/
13816 gfc_data_value
*vnode
;
13822 /* Advance the values structure to point to the next value in the data list. */
13825 next_data_value (void)
13827 while (mpz_cmp_ui (values
.left
, 0) == 0)
13830 if (values
.vnode
->next
== NULL
)
13833 values
.vnode
= values
.vnode
->next
;
13834 mpz_set (values
.left
, values
.vnode
->repeat
);
13842 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13848 ar_type mark
= AR_UNKNOWN
;
13850 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13856 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
13860 mpz_init_set_si (offset
, 0);
13863 if (e
->expr_type
!= EXPR_VARIABLE
)
13864 gfc_internal_error ("check_data_variable(): Bad expression");
13866 sym
= e
->symtree
->n
.sym
;
13868 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13870 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13871 sym
->name
, &sym
->declared_at
);
13874 if (e
->ref
== NULL
&& sym
->as
)
13876 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13877 " declaration", sym
->name
, where
);
13881 has_pointer
= sym
->attr
.pointer
;
13883 if (gfc_is_coindexed (e
))
13885 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13890 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13892 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13896 && ref
->type
== REF_ARRAY
13897 && ref
->u
.ar
.type
!= AR_FULL
)
13899 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13900 "be a full array", sym
->name
, where
);
13905 if (e
->rank
== 0 || has_pointer
)
13907 mpz_init_set_ui (size
, 1);
13914 /* Find the array section reference. */
13915 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13917 if (ref
->type
!= REF_ARRAY
)
13919 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13925 /* Set marks according to the reference pattern. */
13926 switch (ref
->u
.ar
.type
)
13934 /* Get the start position of array section. */
13935 gfc_get_section_index (ar
, section_index
, &offset
);
13940 gcc_unreachable ();
13943 if (gfc_array_size (e
, &size
) == FAILURE
)
13945 gfc_error ("Nonconstant array section at %L in DATA statement",
13947 mpz_clear (offset
);
13954 while (mpz_cmp_ui (size
, 0) > 0)
13956 if (next_data_value () == FAILURE
)
13958 gfc_error ("DATA statement at %L has more variables than values",
13964 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13968 /* If we have more than one element left in the repeat count,
13969 and we have more than one element left in the target variable,
13970 then create a range assignment. */
13971 /* FIXME: Only done for full arrays for now, since array sections
13973 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13974 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13978 if (mpz_cmp (size
, values
.left
) >= 0)
13980 mpz_init_set (range
, values
.left
);
13981 mpz_sub (size
, size
, values
.left
);
13982 mpz_set_ui (values
.left
, 0);
13986 mpz_init_set (range
, size
);
13987 mpz_sub (values
.left
, values
.left
, size
);
13988 mpz_set_ui (size
, 0);
13991 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13994 mpz_add (offset
, offset
, range
);
14001 /* Assign initial value to symbol. */
14004 mpz_sub_ui (values
.left
, values
.left
, 1);
14005 mpz_sub_ui (size
, size
, 1);
14007 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
14012 if (mark
== AR_FULL
)
14013 mpz_add_ui (offset
, offset
, 1);
14015 /* Modify the array section indexes and recalculate the offset
14016 for next element. */
14017 else if (mark
== AR_SECTION
)
14018 gfc_advance_section (section_index
, ar
, &offset
);
14022 if (mark
== AR_SECTION
)
14024 for (i
= 0; i
< ar
->dimen
; i
++)
14025 mpz_clear (section_index
[i
]);
14029 mpz_clear (offset
);
14035 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
14037 /* Iterate over a list of elements in a DATA statement. */
14040 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
14043 iterator_stack frame
;
14044 gfc_expr
*e
, *start
, *end
, *step
;
14045 gfc_try retval
= SUCCESS
;
14047 mpz_init (frame
.value
);
14050 start
= gfc_copy_expr (var
->iter
.start
);
14051 end
= gfc_copy_expr (var
->iter
.end
);
14052 step
= gfc_copy_expr (var
->iter
.step
);
14054 if (gfc_simplify_expr (start
, 1) == FAILURE
14055 || start
->expr_type
!= EXPR_CONSTANT
)
14057 gfc_error ("start of implied-do loop at %L could not be "
14058 "simplified to a constant value", &start
->where
);
14062 if (gfc_simplify_expr (end
, 1) == FAILURE
14063 || end
->expr_type
!= EXPR_CONSTANT
)
14065 gfc_error ("end of implied-do loop at %L could not be "
14066 "simplified to a constant value", &start
->where
);
14070 if (gfc_simplify_expr (step
, 1) == FAILURE
14071 || step
->expr_type
!= EXPR_CONSTANT
)
14073 gfc_error ("step of implied-do loop at %L could not be "
14074 "simplified to a constant value", &start
->where
);
14079 mpz_set (trip
, end
->value
.integer
);
14080 mpz_sub (trip
, trip
, start
->value
.integer
);
14081 mpz_add (trip
, trip
, step
->value
.integer
);
14083 mpz_div (trip
, trip
, step
->value
.integer
);
14085 mpz_set (frame
.value
, start
->value
.integer
);
14087 frame
.prev
= iter_stack
;
14088 frame
.variable
= var
->iter
.var
->symtree
;
14089 iter_stack
= &frame
;
14091 while (mpz_cmp_ui (trip
, 0) > 0)
14093 if (traverse_data_var (var
->list
, where
) == FAILURE
)
14099 e
= gfc_copy_expr (var
->expr
);
14100 if (gfc_simplify_expr (e
, 1) == FAILURE
)
14107 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
14109 mpz_sub_ui (trip
, trip
, 1);
14113 mpz_clear (frame
.value
);
14116 gfc_free_expr (start
);
14117 gfc_free_expr (end
);
14118 gfc_free_expr (step
);
14120 iter_stack
= frame
.prev
;
14125 /* Type resolve variables in the variable list of a DATA statement. */
14128 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
14132 for (; var
; var
= var
->next
)
14134 if (var
->expr
== NULL
)
14135 t
= traverse_data_list (var
, where
);
14137 t
= check_data_variable (var
, where
);
14147 /* Resolve the expressions and iterators associated with a data statement.
14148 This is separate from the assignment checking because data lists should
14149 only be resolved once. */
14152 resolve_data_variables (gfc_data_variable
*d
)
14154 for (; d
; d
= d
->next
)
14156 if (d
->list
== NULL
)
14158 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
14163 if (gfc_resolve_iterator (&d
->iter
, false, true) == FAILURE
)
14166 if (resolve_data_variables (d
->list
) == FAILURE
)
14175 /* Resolve a single DATA statement. We implement this by storing a pointer to
14176 the value list into static variables, and then recursively traversing the
14177 variables list, expanding iterators and such. */
14180 resolve_data (gfc_data
*d
)
14183 if (resolve_data_variables (d
->var
) == FAILURE
)
14186 values
.vnode
= d
->value
;
14187 if (d
->value
== NULL
)
14188 mpz_set_ui (values
.left
, 0);
14190 mpz_set (values
.left
, d
->value
->repeat
);
14192 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
14195 /* At this point, we better not have any values left. */
14197 if (next_data_value () == SUCCESS
)
14198 gfc_error ("DATA statement at %L has more values than variables",
14203 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
14204 accessed by host or use association, is a dummy argument to a pure function,
14205 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
14206 is storage associated with any such variable, shall not be used in the
14207 following contexts: (clients of this function). */
14209 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
14210 procedure. Returns zero if assignment is OK, nonzero if there is a
14213 gfc_impure_variable (gfc_symbol
*sym
)
14218 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
14221 /* Check if the symbol's ns is inside the pure procedure. */
14222 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14226 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
14230 proc
= sym
->ns
->proc_name
;
14231 if (sym
->attr
.dummy
14232 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
14233 || proc
->attr
.function
))
14236 /* TODO: Sort out what can be storage associated, if anything, and include
14237 it here. In principle equivalences should be scanned but it does not
14238 seem to be possible to storage associate an impure variable this way. */
14243 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
14244 current namespace is inside a pure procedure. */
14247 gfc_pure (gfc_symbol
*sym
)
14249 symbol_attribute attr
;
14254 /* Check if the current namespace or one of its parents
14255 belongs to a pure procedure. */
14256 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14258 sym
= ns
->proc_name
;
14262 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
14270 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
14274 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
14275 checks if the current namespace is implicitly pure. Note that this
14276 function returns false for a PURE procedure. */
14279 gfc_implicit_pure (gfc_symbol
*sym
)
14285 /* Check if the current procedure is implicit_pure. Walk up
14286 the procedure list until we find a procedure. */
14287 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
14289 sym
= ns
->proc_name
;
14293 if (sym
->attr
.flavor
== FL_PROCEDURE
)
14298 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
14299 && !sym
->attr
.pure
;
14303 /* Test whether the current procedure is elemental or not. */
14306 gfc_elemental (gfc_symbol
*sym
)
14308 symbol_attribute attr
;
14311 sym
= gfc_current_ns
->proc_name
;
14316 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
14320 /* Warn about unused labels. */
14323 warn_unused_fortran_label (gfc_st_label
*label
)
14328 warn_unused_fortran_label (label
->left
);
14330 if (label
->defined
== ST_LABEL_UNKNOWN
)
14333 switch (label
->referenced
)
14335 case ST_LABEL_UNKNOWN
:
14336 gfc_warning ("Label %d at %L defined but not used", label
->value
,
14340 case ST_LABEL_BAD_TARGET
:
14341 gfc_warning ("Label %d at %L defined but cannot be used",
14342 label
->value
, &label
->where
);
14349 warn_unused_fortran_label (label
->right
);
14353 /* Returns the sequence type of a symbol or sequence. */
14356 sequence_type (gfc_typespec ts
)
14365 if (ts
.u
.derived
->components
== NULL
)
14366 return SEQ_NONDEFAULT
;
14368 result
= sequence_type (ts
.u
.derived
->components
->ts
);
14369 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
14370 if (sequence_type (c
->ts
) != result
)
14376 if (ts
.kind
!= gfc_default_character_kind
)
14377 return SEQ_NONDEFAULT
;
14379 return SEQ_CHARACTER
;
14382 if (ts
.kind
!= gfc_default_integer_kind
)
14383 return SEQ_NONDEFAULT
;
14385 return SEQ_NUMERIC
;
14388 if (!(ts
.kind
== gfc_default_real_kind
14389 || ts
.kind
== gfc_default_double_kind
))
14390 return SEQ_NONDEFAULT
;
14392 return SEQ_NUMERIC
;
14395 if (ts
.kind
!= gfc_default_complex_kind
)
14396 return SEQ_NONDEFAULT
;
14398 return SEQ_NUMERIC
;
14401 if (ts
.kind
!= gfc_default_logical_kind
)
14402 return SEQ_NONDEFAULT
;
14404 return SEQ_NUMERIC
;
14407 return SEQ_NONDEFAULT
;
14412 /* Resolve derived type EQUIVALENCE object. */
14415 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
14417 gfc_component
*c
= derived
->components
;
14422 /* Shall not be an object of nonsequence derived type. */
14423 if (!derived
->attr
.sequence
)
14425 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
14426 "attribute to be an EQUIVALENCE object", sym
->name
,
14431 /* Shall not have allocatable components. */
14432 if (derived
->attr
.alloc_comp
)
14434 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
14435 "components to be an EQUIVALENCE object",sym
->name
,
14440 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
14442 gfc_error ("Derived type variable '%s' at %L with default "
14443 "initialization cannot be in EQUIVALENCE with a variable "
14444 "in COMMON", sym
->name
, &e
->where
);
14448 for (; c
; c
= c
->next
)
14450 if (c
->ts
.type
== BT_DERIVED
14451 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
14454 /* Shall not be an object of sequence derived type containing a pointer
14455 in the structure. */
14456 if (c
->attr
.pointer
)
14458 gfc_error ("Derived type variable '%s' at %L with pointer "
14459 "component(s) cannot be an EQUIVALENCE object",
14460 sym
->name
, &e
->where
);
14468 /* Resolve equivalence object.
14469 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
14470 an allocatable array, an object of nonsequence derived type, an object of
14471 sequence derived type containing a pointer at any level of component
14472 selection, an automatic object, a function name, an entry name, a result
14473 name, a named constant, a structure component, or a subobject of any of
14474 the preceding objects. A substring shall not have length zero. A
14475 derived type shall not have components with default initialization nor
14476 shall two objects of an equivalence group be initialized.
14477 Either all or none of the objects shall have an protected attribute.
14478 The simple constraints are done in symbol.c(check_conflict) and the rest
14479 are implemented here. */
14482 resolve_equivalence (gfc_equiv
*eq
)
14485 gfc_symbol
*first_sym
;
14488 locus
*last_where
= NULL
;
14489 seq_type eq_type
, last_eq_type
;
14490 gfc_typespec
*last_ts
;
14491 int object
, cnt_protected
;
14494 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
14496 first_sym
= eq
->expr
->symtree
->n
.sym
;
14500 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
14504 e
->ts
= e
->symtree
->n
.sym
->ts
;
14505 /* match_varspec might not know yet if it is seeing
14506 array reference or substring reference, as it doesn't
14508 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
14510 gfc_ref
*ref
= e
->ref
;
14511 sym
= e
->symtree
->n
.sym
;
14513 if (sym
->attr
.dimension
)
14515 ref
->u
.ar
.as
= sym
->as
;
14519 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
14520 if (e
->ts
.type
== BT_CHARACTER
14522 && ref
->type
== REF_ARRAY
14523 && ref
->u
.ar
.dimen
== 1
14524 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
14525 && ref
->u
.ar
.stride
[0] == NULL
)
14527 gfc_expr
*start
= ref
->u
.ar
.start
[0];
14528 gfc_expr
*end
= ref
->u
.ar
.end
[0];
14531 /* Optimize away the (:) reference. */
14532 if (start
== NULL
&& end
== NULL
)
14535 e
->ref
= ref
->next
;
14537 e
->ref
->next
= ref
->next
;
14542 ref
->type
= REF_SUBSTRING
;
14544 start
= gfc_get_int_expr (gfc_default_integer_kind
,
14546 ref
->u
.ss
.start
= start
;
14547 if (end
== NULL
&& e
->ts
.u
.cl
)
14548 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
14549 ref
->u
.ss
.end
= end
;
14550 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
14557 /* Any further ref is an error. */
14560 gcc_assert (ref
->type
== REF_ARRAY
);
14561 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
14567 if (gfc_resolve_expr (e
) == FAILURE
)
14570 sym
= e
->symtree
->n
.sym
;
14572 if (sym
->attr
.is_protected
)
14574 if (cnt_protected
> 0 && cnt_protected
!= object
)
14576 gfc_error ("Either all or none of the objects in the "
14577 "EQUIVALENCE set at %L shall have the "
14578 "PROTECTED attribute",
14583 /* Shall not equivalence common block variables in a PURE procedure. */
14584 if (sym
->ns
->proc_name
14585 && sym
->ns
->proc_name
->attr
.pure
14586 && sym
->attr
.in_common
)
14588 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
14589 "object in the pure procedure '%s'",
14590 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14594 /* Shall not be a named constant. */
14595 if (e
->expr_type
== EXPR_CONSTANT
)
14597 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14598 "object", sym
->name
, &e
->where
);
14602 if (e
->ts
.type
== BT_DERIVED
14603 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
14606 /* Check that the types correspond correctly:
14608 A numeric sequence structure may be equivalenced to another sequence
14609 structure, an object of default integer type, default real type, double
14610 precision real type, default logical type such that components of the
14611 structure ultimately only become associated to objects of the same
14612 kind. A character sequence structure may be equivalenced to an object
14613 of default character kind or another character sequence structure.
14614 Other objects may be equivalenced only to objects of the same type and
14615 kind parameters. */
14617 /* Identical types are unconditionally OK. */
14618 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14619 goto identical_types
;
14621 last_eq_type
= sequence_type (*last_ts
);
14622 eq_type
= sequence_type (sym
->ts
);
14624 /* Since the pair of objects is not of the same type, mixed or
14625 non-default sequences can be rejected. */
14627 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14628 "statement at %L with different type objects";
14630 && last_eq_type
== SEQ_MIXED
14631 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
14633 || (eq_type
== SEQ_MIXED
14634 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14635 &e
->where
) == FAILURE
))
14638 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14639 "statement at %L with objects of different type";
14641 && last_eq_type
== SEQ_NONDEFAULT
14642 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
14643 last_where
) == FAILURE
)
14644 || (eq_type
== SEQ_NONDEFAULT
14645 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14646 &e
->where
) == FAILURE
))
14649 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14650 "EQUIVALENCE statement at %L";
14651 if (last_eq_type
== SEQ_CHARACTER
14652 && eq_type
!= SEQ_CHARACTER
14653 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14654 &e
->where
) == FAILURE
)
14657 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14658 "EQUIVALENCE statement at %L";
14659 if (last_eq_type
== SEQ_NUMERIC
14660 && eq_type
!= SEQ_NUMERIC
14661 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14662 &e
->where
) == FAILURE
)
14667 last_where
= &e
->where
;
14672 /* Shall not be an automatic array. */
14673 if (e
->ref
->type
== REF_ARRAY
14674 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
14676 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14677 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14684 /* Shall not be a structure component. */
14685 if (r
->type
== REF_COMPONENT
)
14687 gfc_error ("Structure component '%s' at %L cannot be an "
14688 "EQUIVALENCE object",
14689 r
->u
.c
.component
->name
, &e
->where
);
14693 /* A substring shall not have length zero. */
14694 if (r
->type
== REF_SUBSTRING
)
14696 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14698 gfc_error ("Substring at %L has length zero",
14699 &r
->u
.ss
.start
->where
);
14709 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14712 resolve_fntype (gfc_namespace
*ns
)
14714 gfc_entry_list
*el
;
14717 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14720 /* If there are any entries, ns->proc_name is the entry master
14721 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14723 sym
= ns
->entries
->sym
;
14725 sym
= ns
->proc_name
;
14726 if (sym
->result
== sym
14727 && sym
->ts
.type
== BT_UNKNOWN
14728 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
14729 && !sym
->attr
.untyped
)
14731 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14732 sym
->name
, &sym
->declared_at
);
14733 sym
->attr
.untyped
= 1;
14736 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14737 && !sym
->attr
.contained
14738 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14739 && gfc_check_symbol_access (sym
))
14741 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14742 "%L of PRIVATE type '%s'", sym
->name
,
14743 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14747 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14749 if (el
->sym
->result
== el
->sym
14750 && el
->sym
->ts
.type
== BT_UNKNOWN
14751 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
14752 && !el
->sym
->attr
.untyped
)
14754 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14755 el
->sym
->name
, &el
->sym
->declared_at
);
14756 el
->sym
->attr
.untyped
= 1;
14762 /* 12.3.2.1.1 Defined operators. */
14765 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14767 gfc_formal_arglist
*formal
;
14769 if (!sym
->attr
.function
)
14771 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14772 sym
->name
, &where
);
14776 if (sym
->ts
.type
== BT_CHARACTER
14777 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14778 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14779 && sym
->result
->ts
.u
.cl
->length
))
14781 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14782 "character length", sym
->name
, &where
);
14786 formal
= gfc_sym_get_dummy_args (sym
);
14787 if (!formal
|| !formal
->sym
)
14789 gfc_error ("User operator procedure '%s' at %L must have at least "
14790 "one argument", sym
->name
, &where
);
14794 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14796 gfc_error ("First argument of operator interface at %L must be "
14797 "INTENT(IN)", &where
);
14801 if (formal
->sym
->attr
.optional
)
14803 gfc_error ("First argument of operator interface at %L cannot be "
14804 "optional", &where
);
14808 formal
= formal
->next
;
14809 if (!formal
|| !formal
->sym
)
14812 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14814 gfc_error ("Second argument of operator interface at %L must be "
14815 "INTENT(IN)", &where
);
14819 if (formal
->sym
->attr
.optional
)
14821 gfc_error ("Second argument of operator interface at %L cannot be "
14822 "optional", &where
);
14828 gfc_error ("Operator interface at %L must have, at most, two "
14829 "arguments", &where
);
14837 gfc_resolve_uops (gfc_symtree
*symtree
)
14839 gfc_interface
*itr
;
14841 if (symtree
== NULL
)
14844 gfc_resolve_uops (symtree
->left
);
14845 gfc_resolve_uops (symtree
->right
);
14847 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14848 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14852 /* Examine all of the expressions associated with a program unit,
14853 assign types to all intermediate expressions, make sure that all
14854 assignments are to compatible types and figure out which names
14855 refer to which functions or subroutines. It doesn't check code
14856 block, which is handled by resolve_code. */
14859 resolve_types (gfc_namespace
*ns
)
14865 gfc_namespace
* old_ns
= gfc_current_ns
;
14867 /* Check that all IMPLICIT types are ok. */
14868 if (!ns
->seen_implicit_none
)
14871 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14872 if (ns
->set_flag
[letter
]
14873 && resolve_typespec_used (&ns
->default_type
[letter
],
14874 &ns
->implicit_loc
[letter
],
14879 gfc_current_ns
= ns
;
14881 resolve_entries (ns
);
14883 resolve_common_vars (ns
->blank_common
.head
, false);
14884 resolve_common_blocks (ns
->common_root
);
14886 resolve_contained_functions (ns
);
14888 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14889 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14890 resolve_formal_arglist (ns
->proc_name
);
14892 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14894 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14895 resolve_charlen (cl
);
14897 gfc_traverse_ns (ns
, resolve_symbol
);
14899 resolve_fntype (ns
);
14901 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14903 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14904 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14905 "also be PURE", n
->proc_name
->name
,
14906 &n
->proc_name
->declared_at
);
14912 do_concurrent_flag
= 0;
14913 gfc_check_interfaces (ns
);
14915 gfc_traverse_ns (ns
, resolve_values
);
14921 for (d
= ns
->data
; d
; d
= d
->next
)
14925 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14927 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14929 if (ns
->common_root
!= NULL
)
14930 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
14932 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14933 resolve_equivalence (eq
);
14935 /* Warn about unused labels. */
14936 if (warn_unused_label
)
14937 warn_unused_fortran_label (ns
->st_labels
);
14939 gfc_resolve_uops (ns
->uop_root
);
14941 gfc_current_ns
= old_ns
;
14945 /* Call resolve_code recursively. */
14948 resolve_codes (gfc_namespace
*ns
)
14951 bitmap_obstack old_obstack
;
14953 if (ns
->resolved
== 1)
14956 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14959 gfc_current_ns
= ns
;
14961 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14962 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14965 /* Set to an out of range value. */
14966 current_entry_id
= -1;
14968 old_obstack
= labels_obstack
;
14969 bitmap_obstack_initialize (&labels_obstack
);
14971 resolve_code (ns
->code
, ns
);
14973 bitmap_obstack_release (&labels_obstack
);
14974 labels_obstack
= old_obstack
;
14978 /* This function is called after a complete program unit has been compiled.
14979 Its purpose is to examine all of the expressions associated with a program
14980 unit, assign types to all intermediate expressions, make sure that all
14981 assignments are to compatible types and figure out which names refer to
14982 which functions or subroutines. */
14985 gfc_resolve (gfc_namespace
*ns
)
14987 gfc_namespace
*old_ns
;
14988 code_stack
*old_cs_base
;
14994 old_ns
= gfc_current_ns
;
14995 old_cs_base
= cs_base
;
14997 resolve_types (ns
);
14998 component_assignment_level
= 0;
14999 resolve_codes (ns
);
15001 gfc_current_ns
= old_ns
;
15002 cs_base
= old_cs_base
;
15005 gfc_run_passes (ns
);