1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
30 #include "arith.h" /* For gfc_compare_expr(). */
31 #include "dependency.h"
33 #include "target-memory.h" /* for gfc_simplify_transfer */
34 #include "constructor.h"
36 /* Types used in equivalence statements. */
40 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
44 /* Stack to keep track of the nesting of blocks as we move through the
45 code. See resolve_branch() and resolve_code(). */
47 typedef struct code_stack
49 struct gfc_code
*head
, *current
;
50 struct code_stack
*prev
;
52 /* This bitmap keeps track of the targets valid for a branch from
53 inside this block except for END {IF|SELECT}s of enclosing
55 bitmap reachable_labels
;
59 static code_stack
*cs_base
= NULL
;
62 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
64 static int forall_flag
;
65 static int do_concurrent_flag
;
67 /* True when we are resolving an expression that is an actual argument to
69 static bool actual_arg
= false;
70 /* True when we are resolving an expression that is the first actual argument
72 static bool first_actual_arg
= false;
75 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
77 static int omp_workshare_flag
;
79 /* Nonzero if we are processing a formal arglist. The corresponding function
80 resets the flag each time that it is read. */
81 static int formal_arg_flag
= 0;
83 /* True if we are resolving a specification expression. */
84 static int specification_expr
= 0;
86 /* The id of the last entry seen. */
87 static int current_entry_id
;
89 /* We use bitmaps to determine if a branch target is valid. */
90 static bitmap_obstack labels_obstack
;
92 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
93 static bool inquiry_argument
= false;
97 gfc_is_formal_arg (void)
99 return formal_arg_flag
;
102 /* Is the symbol host associated? */
104 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
106 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
115 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
116 an ABSTRACT derived-type. If where is not NULL, an error message with that
117 locus is printed, optionally using name. */
120 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
122 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
127 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
128 name
, where
, ts
->u
.derived
->name
);
130 gfc_error ("ABSTRACT type '%s' used at %L",
131 ts
->u
.derived
->name
, where
);
141 static void resolve_symbol (gfc_symbol
*sym
);
142 static gfc_try
resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
);
145 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
148 resolve_procedure_interface (gfc_symbol
*sym
)
150 if (sym
->ts
.interface
== sym
)
152 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
153 sym
->name
, &sym
->declared_at
);
156 if (sym
->ts
.interface
->attr
.procedure
)
158 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
159 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
160 sym
->name
, &sym
->declared_at
);
164 /* Get the attributes from the interface (now resolved). */
165 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
167 gfc_symbol
*ifc
= sym
->ts
.interface
;
168 resolve_symbol (ifc
);
170 if (ifc
->attr
.intrinsic
)
171 resolve_intrinsic (ifc
, &ifc
->declared_at
);
175 sym
->ts
= ifc
->result
->ts
;
180 sym
->ts
.interface
= ifc
;
181 sym
->attr
.function
= ifc
->attr
.function
;
182 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
183 gfc_copy_formal_args (sym
, ifc
, IFSRC_DECL
);
185 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
186 sym
->attr
.pointer
= ifc
->attr
.pointer
;
187 sym
->attr
.pure
= ifc
->attr
.pure
;
188 sym
->attr
.elemental
= ifc
->attr
.elemental
;
189 sym
->attr
.dimension
= ifc
->attr
.dimension
;
190 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
191 sym
->attr
.recursive
= ifc
->attr
.recursive
;
192 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
193 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
194 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
195 /* Copy array spec. */
196 sym
->as
= gfc_copy_array_spec (ifc
->as
);
200 for (i
= 0; i
< sym
->as
->rank
; i
++)
202 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
203 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
206 /* Copy char length. */
207 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
209 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
210 gfc_expr_replace_symbols (sym
->ts
.u
.cl
->length
, sym
);
211 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
212 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
216 else if (sym
->ts
.interface
->name
[0] != '\0')
218 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
219 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
227 /* Resolve types of formal argument lists. These have to be done early so that
228 the formal argument lists of module procedures can be copied to the
229 containing module before the individual procedures are resolved
230 individually. We also resolve argument lists of procedures in interface
231 blocks because they are self-contained scoping units.
233 Since a dummy argument cannot be a non-dummy procedure, the only
234 resort left for untyped names are the IMPLICIT types. */
237 resolve_formal_arglist (gfc_symbol
*proc
)
239 gfc_formal_arglist
*f
;
243 if (proc
->result
!= NULL
)
248 if (gfc_elemental (proc
)
249 || sym
->attr
.pointer
|| sym
->attr
.allocatable
250 || (sym
->as
&& sym
->as
->rank
!= 0))
252 proc
->attr
.always_explicit
= 1;
253 sym
->attr
.always_explicit
= 1;
258 for (f
= proc
->formal
; f
; f
= f
->next
)
265 /* Alternate return placeholder. */
266 if (gfc_elemental (proc
))
267 gfc_error ("Alternate return specifier in elemental subroutine "
268 "'%s' at %L is not allowed", proc
->name
,
270 if (proc
->attr
.function
)
271 gfc_error ("Alternate return specifier in function "
272 "'%s' at %L is not allowed", proc
->name
,
276 else if (sym
->attr
.procedure
&& sym
->ts
.interface
277 && sym
->attr
.if_source
!= IFSRC_DECL
)
278 resolve_procedure_interface (sym
);
280 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
281 resolve_formal_arglist (sym
);
283 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
285 if (sym
->attr
.flavor
== FL_UNKNOWN
)
286 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
290 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
291 && (!sym
->attr
.function
|| sym
->result
== sym
))
292 gfc_set_default_type (sym
, 1, sym
->ns
);
295 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
296 ? CLASS_DATA (sym
)->as
: sym
->as
;
298 gfc_resolve_array_spec (as
, 0);
300 /* We can't tell if an array with dimension (:) is assumed or deferred
301 shape until we know if it has the pointer or allocatable attributes.
303 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
304 && ((sym
->ts
.type
!= BT_CLASS
305 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
306 || (sym
->ts
.type
== BT_CLASS
307 && !(CLASS_DATA (sym
)->attr
.class_pointer
308 || CLASS_DATA (sym
)->attr
.allocatable
)))
309 && sym
->attr
.flavor
!= FL_PROCEDURE
)
311 as
->type
= AS_ASSUMED_SHAPE
;
312 for (i
= 0; i
< as
->rank
; i
++)
313 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
316 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
317 || (as
&& as
->type
== AS_ASSUMED_RANK
)
318 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
319 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
320 && (CLASS_DATA (sym
)->attr
.class_pointer
321 || CLASS_DATA (sym
)->attr
.allocatable
322 || CLASS_DATA (sym
)->attr
.target
))
323 || sym
->attr
.optional
)
325 proc
->attr
.always_explicit
= 1;
327 proc
->result
->attr
.always_explicit
= 1;
330 /* If the flavor is unknown at this point, it has to be a variable.
331 A procedure specification would have already set the type. */
333 if (sym
->attr
.flavor
== FL_UNKNOWN
)
334 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
338 if (sym
->attr
.flavor
== FL_PROCEDURE
)
343 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
344 "also be PURE", sym
->name
, &sym
->declared_at
);
348 else if (!sym
->attr
.pointer
)
350 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
353 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
354 " of pure function '%s' at %L with VALUE "
355 "attribute but without INTENT(IN)",
356 sym
->name
, proc
->name
, &sym
->declared_at
);
358 gfc_error ("Argument '%s' of pure function '%s' at %L must "
359 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
363 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
366 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
367 " of pure subroutine '%s' at %L with VALUE "
368 "attribute but without INTENT", sym
->name
,
369 proc
->name
, &sym
->declared_at
);
371 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
372 "must have its INTENT specified or have the "
373 "VALUE attribute", sym
->name
, proc
->name
,
379 if (proc
->attr
.implicit_pure
)
381 if (sym
->attr
.flavor
== FL_PROCEDURE
)
384 proc
->attr
.implicit_pure
= 0;
386 else if (!sym
->attr
.pointer
)
388 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
389 proc
->attr
.implicit_pure
= 0;
391 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
392 proc
->attr
.implicit_pure
= 0;
396 if (gfc_elemental (proc
))
399 if (sym
->attr
.codimension
400 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
401 && CLASS_DATA (sym
)->attr
.codimension
))
403 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
404 "procedure", sym
->name
, &sym
->declared_at
);
408 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
409 && CLASS_DATA (sym
)->as
))
411 gfc_error ("Argument '%s' of elemental procedure at %L must "
412 "be scalar", sym
->name
, &sym
->declared_at
);
416 if (sym
->attr
.allocatable
417 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
418 && CLASS_DATA (sym
)->attr
.allocatable
))
420 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
421 "have the ALLOCATABLE attribute", sym
->name
,
426 if (sym
->attr
.pointer
427 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
428 && CLASS_DATA (sym
)->attr
.class_pointer
))
430 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
431 "have the POINTER attribute", sym
->name
,
436 if (sym
->attr
.flavor
== FL_PROCEDURE
)
438 gfc_error ("Dummy procedure '%s' not allowed in elemental "
439 "procedure '%s' at %L", sym
->name
, proc
->name
,
444 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
446 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
447 "have its INTENT specified", sym
->name
, proc
->name
,
453 /* Each dummy shall be specified to be scalar. */
454 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
458 gfc_error ("Argument '%s' of statement function at %L must "
459 "be scalar", sym
->name
, &sym
->declared_at
);
463 if (sym
->ts
.type
== BT_CHARACTER
)
465 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
466 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
468 gfc_error ("Character-valued argument '%s' of statement "
469 "function at %L must have constant length",
470 sym
->name
, &sym
->declared_at
);
480 /* Work function called when searching for symbols that have argument lists
481 associated with them. */
484 find_arglists (gfc_symbol
*sym
)
486 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
487 || sym
->attr
.flavor
== FL_DERIVED
)
490 resolve_formal_arglist (sym
);
494 /* Given a namespace, resolve all formal argument lists within the namespace.
498 resolve_formal_arglists (gfc_namespace
*ns
)
503 gfc_traverse_ns (ns
, find_arglists
);
508 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
512 /* If this namespace is not a function or an entry master function,
514 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
515 || sym
->attr
.entry_master
)
518 /* Try to find out of what the return type is. */
519 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
521 t
= gfc_set_default_type (sym
->result
, 0, ns
);
523 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
525 if (sym
->result
== sym
)
526 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
527 sym
->name
, &sym
->declared_at
);
528 else if (!sym
->result
->attr
.proc_pointer
)
529 gfc_error ("Result '%s' of contained function '%s' at %L has "
530 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
531 &sym
->result
->declared_at
);
532 sym
->result
->attr
.untyped
= 1;
536 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
537 type, lists the only ways a character length value of * can be used:
538 dummy arguments of procedures, named constants, and function results
539 in external functions. Internal function results and results of module
540 procedures are not on this list, ergo, not permitted. */
542 if (sym
->result
->ts
.type
== BT_CHARACTER
)
544 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
545 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
547 /* See if this is a module-procedure and adapt error message
550 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
551 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
553 gfc_error ("Character-valued %s '%s' at %L must not be"
555 module_proc
? _("module procedure")
556 : _("internal function"),
557 sym
->name
, &sym
->declared_at
);
563 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
564 introduce duplicates. */
567 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
569 gfc_formal_arglist
*f
, *new_arglist
;
572 for (; new_args
!= NULL
; new_args
= new_args
->next
)
574 new_sym
= new_args
->sym
;
575 /* See if this arg is already in the formal argument list. */
576 for (f
= proc
->formal
; f
; f
= f
->next
)
578 if (new_sym
== f
->sym
)
585 /* Add a new argument. Argument order is not important. */
586 new_arglist
= gfc_get_formal_arglist ();
587 new_arglist
->sym
= new_sym
;
588 new_arglist
->next
= proc
->formal
;
589 proc
->formal
= new_arglist
;
594 /* Flag the arguments that are not present in all entries. */
597 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
599 gfc_formal_arglist
*f
, *head
;
602 for (f
= proc
->formal
; f
; f
= f
->next
)
607 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
609 if (new_args
->sym
== f
->sym
)
616 f
->sym
->attr
.not_always_present
= 1;
621 /* Resolve alternate entry points. If a symbol has multiple entry points we
622 create a new master symbol for the main routine, and turn the existing
623 symbol into an entry point. */
626 resolve_entries (gfc_namespace
*ns
)
628 gfc_namespace
*old_ns
;
632 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
633 static int master_count
= 0;
635 if (ns
->proc_name
== NULL
)
638 /* No need to do anything if this procedure doesn't have alternate entry
643 /* We may already have resolved alternate entry points. */
644 if (ns
->proc_name
->attr
.entry_master
)
647 /* If this isn't a procedure something has gone horribly wrong. */
648 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
650 /* Remember the current namespace. */
651 old_ns
= gfc_current_ns
;
655 /* Add the main entry point to the list of entry points. */
656 el
= gfc_get_entry_list ();
657 el
->sym
= ns
->proc_name
;
659 el
->next
= ns
->entries
;
661 ns
->proc_name
->attr
.entry
= 1;
663 /* If it is a module function, it needs to be in the right namespace
664 so that gfc_get_fake_result_decl can gather up the results. The
665 need for this arose in get_proc_name, where these beasts were
666 left in their own namespace, to keep prior references linked to
667 the entry declaration.*/
668 if (ns
->proc_name
->attr
.function
669 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
672 /* Do the same for entries where the master is not a module
673 procedure. These are retained in the module namespace because
674 of the module procedure declaration. */
675 for (el
= el
->next
; el
; el
= el
->next
)
676 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
677 && el
->sym
->attr
.mod_proc
)
681 /* Add an entry statement for it. */
688 /* Create a new symbol for the master function. */
689 /* Give the internal function a unique name (within this file).
690 Also include the function name so the user has some hope of figuring
691 out what is going on. */
692 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
693 master_count
++, ns
->proc_name
->name
);
694 gfc_get_ha_symbol (name
, &proc
);
695 gcc_assert (proc
!= NULL
);
697 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
698 if (ns
->proc_name
->attr
.subroutine
)
699 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
703 gfc_typespec
*ts
, *fts
;
704 gfc_array_spec
*as
, *fas
;
705 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
707 fas
= ns
->entries
->sym
->as
;
708 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
709 fts
= &ns
->entries
->sym
->result
->ts
;
710 if (fts
->type
== BT_UNKNOWN
)
711 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
712 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
714 ts
= &el
->sym
->result
->ts
;
716 as
= as
? as
: el
->sym
->result
->as
;
717 if (ts
->type
== BT_UNKNOWN
)
718 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
720 if (! gfc_compare_types (ts
, fts
)
721 || (el
->sym
->result
->attr
.dimension
722 != ns
->entries
->sym
->result
->attr
.dimension
)
723 || (el
->sym
->result
->attr
.pointer
724 != ns
->entries
->sym
->result
->attr
.pointer
))
726 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
727 && gfc_compare_array_spec (as
, fas
) == 0)
728 gfc_error ("Function %s at %L has entries with mismatched "
729 "array specifications", ns
->entries
->sym
->name
,
730 &ns
->entries
->sym
->declared_at
);
731 /* The characteristics need to match and thus both need to have
732 the same string length, i.e. both len=*, or both len=4.
733 Having both len=<variable> is also possible, but difficult to
734 check at compile time. */
735 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
736 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
737 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
739 && ts
->u
.cl
->length
->expr_type
740 != fts
->u
.cl
->length
->expr_type
)
742 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
743 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
744 fts
->u
.cl
->length
->value
.integer
) != 0)))
745 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
746 "entries returning variables of different "
747 "string lengths", ns
->entries
->sym
->name
,
748 &ns
->entries
->sym
->declared_at
);
753 sym
= ns
->entries
->sym
->result
;
754 /* All result types the same. */
756 if (sym
->attr
.dimension
)
757 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
758 if (sym
->attr
.pointer
)
759 gfc_add_pointer (&proc
->attr
, NULL
);
763 /* Otherwise the result will be passed through a union by
765 proc
->attr
.mixed_entry_master
= 1;
766 for (el
= ns
->entries
; el
; el
= el
->next
)
768 sym
= el
->sym
->result
;
769 if (sym
->attr
.dimension
)
771 if (el
== ns
->entries
)
772 gfc_error ("FUNCTION result %s can't be an array in "
773 "FUNCTION %s at %L", sym
->name
,
774 ns
->entries
->sym
->name
, &sym
->declared_at
);
776 gfc_error ("ENTRY result %s can't be an array in "
777 "FUNCTION %s at %L", sym
->name
,
778 ns
->entries
->sym
->name
, &sym
->declared_at
);
780 else if (sym
->attr
.pointer
)
782 if (el
== ns
->entries
)
783 gfc_error ("FUNCTION result %s can't be a POINTER in "
784 "FUNCTION %s at %L", sym
->name
,
785 ns
->entries
->sym
->name
, &sym
->declared_at
);
787 gfc_error ("ENTRY result %s can't be a POINTER in "
788 "FUNCTION %s at %L", sym
->name
,
789 ns
->entries
->sym
->name
, &sym
->declared_at
);
794 if (ts
->type
== BT_UNKNOWN
)
795 ts
= gfc_get_default_type (sym
->name
, NULL
);
799 if (ts
->kind
== gfc_default_integer_kind
)
803 if (ts
->kind
== gfc_default_real_kind
804 || ts
->kind
== gfc_default_double_kind
)
808 if (ts
->kind
== gfc_default_complex_kind
)
812 if (ts
->kind
== gfc_default_logical_kind
)
816 /* We will issue error elsewhere. */
824 if (el
== ns
->entries
)
825 gfc_error ("FUNCTION result %s can't be of type %s "
826 "in FUNCTION %s at %L", sym
->name
,
827 gfc_typename (ts
), ns
->entries
->sym
->name
,
830 gfc_error ("ENTRY result %s can't be of type %s "
831 "in FUNCTION %s at %L", sym
->name
,
832 gfc_typename (ts
), ns
->entries
->sym
->name
,
839 proc
->attr
.access
= ACCESS_PRIVATE
;
840 proc
->attr
.entry_master
= 1;
842 /* Merge all the entry point arguments. */
843 for (el
= ns
->entries
; el
; el
= el
->next
)
844 merge_argument_lists (proc
, el
->sym
->formal
);
846 /* Check the master formal arguments for any that are not
847 present in all entry points. */
848 for (el
= ns
->entries
; el
; el
= el
->next
)
849 check_argument_lists (proc
, el
->sym
->formal
);
851 /* Use the master function for the function body. */
852 ns
->proc_name
= proc
;
854 /* Finalize the new symbols. */
855 gfc_commit_symbols ();
857 /* Restore the original namespace. */
858 gfc_current_ns
= old_ns
;
862 /* Resolve common variables. */
864 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
866 gfc_symbol
*csym
= sym
;
868 for (; csym
; csym
= csym
->common_next
)
870 if (csym
->value
|| csym
->attr
.data
)
872 if (!csym
->ns
->is_block_data
)
873 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
874 "but only in BLOCK DATA initialization is "
875 "allowed", csym
->name
, &csym
->declared_at
);
876 else if (!named_common
)
877 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
878 "in a blank COMMON but initialization is only "
879 "allowed in named common blocks", csym
->name
,
883 if (csym
->ts
.type
!= BT_DERIVED
)
886 if (!(csym
->ts
.u
.derived
->attr
.sequence
887 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
888 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
889 "has neither the SEQUENCE nor the BIND(C) "
890 "attribute", csym
->name
, &csym
->declared_at
);
891 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
892 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
893 "has an ultimate component that is "
894 "allocatable", csym
->name
, &csym
->declared_at
);
895 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
896 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
897 "may not have default initializer", csym
->name
,
900 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
901 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
905 /* Resolve common blocks. */
907 resolve_common_blocks (gfc_symtree
*common_root
)
911 if (common_root
== NULL
)
914 if (common_root
->left
)
915 resolve_common_blocks (common_root
->left
);
916 if (common_root
->right
)
917 resolve_common_blocks (common_root
->right
);
919 resolve_common_vars (common_root
->n
.common
->head
, true);
921 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
925 if (sym
->attr
.flavor
== FL_PARAMETER
)
926 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
927 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
929 if (sym
->attr
.external
)
930 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
931 sym
->name
, &common_root
->n
.common
->where
);
933 if (sym
->attr
.intrinsic
)
934 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
935 sym
->name
, &common_root
->n
.common
->where
);
936 else if (sym
->attr
.result
937 || gfc_is_function_return_value (sym
, gfc_current_ns
))
938 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
939 "that is also a function result", sym
->name
,
940 &common_root
->n
.common
->where
);
941 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
942 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
943 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
944 "that is also a global procedure", sym
->name
,
945 &common_root
->n
.common
->where
);
949 /* Resolve contained function types. Because contained functions can call one
950 another, they have to be worked out before any of the contained procedures
953 The good news is that if a function doesn't already have a type, the only
954 way it can get one is through an IMPLICIT type or a RESULT variable, because
955 by definition contained functions are contained namespace they're contained
956 in, not in a sibling or parent namespace. */
959 resolve_contained_functions (gfc_namespace
*ns
)
961 gfc_namespace
*child
;
964 resolve_formal_arglists (ns
);
966 for (child
= ns
->contained
; child
; child
= child
->sibling
)
968 /* Resolve alternate entry points first. */
969 resolve_entries (child
);
971 /* Then check function return types. */
972 resolve_contained_fntype (child
->proc_name
, child
);
973 for (el
= child
->entries
; el
; el
= el
->next
)
974 resolve_contained_fntype (el
->sym
, child
);
979 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
982 /* Resolve all of the elements of a structure constructor and make sure that
983 the types are correct. The 'init' flag indicates that the given
984 constructor is an initializer. */
987 resolve_structure_cons (gfc_expr
*expr
, int init
)
989 gfc_constructor
*cons
;
996 if (expr
->ts
.type
== BT_DERIVED
)
997 resolve_fl_derived0 (expr
->ts
.u
.derived
);
999 cons
= gfc_constructor_first (expr
->value
.constructor
);
1001 /* See if the user is trying to invoke a structure constructor for one of
1002 the iso_c_binding derived types. */
1003 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1004 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1005 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
1007 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
1008 expr
->ts
.u
.derived
->name
, &(expr
->where
));
1012 /* Return if structure constructor is c_null_(fun)prt. */
1013 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1014 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1015 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
1018 /* A constructor may have references if it is the result of substituting a
1019 parameter variable. In this case we just pull out the component we
1022 comp
= expr
->ref
->u
.c
.sym
->components
;
1024 comp
= expr
->ts
.u
.derived
->components
;
1026 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1033 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1039 rank
= comp
->as
? comp
->as
->rank
: 0;
1040 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1041 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1043 gfc_error ("The rank of the element in the structure "
1044 "constructor at %L does not match that of the "
1045 "component (%d/%d)", &cons
->expr
->where
,
1046 cons
->expr
->rank
, rank
);
1050 /* If we don't have the right type, try to convert it. */
1052 if (!comp
->attr
.proc_pointer
&&
1053 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1056 if (strcmp (comp
->name
, "_extends") == 0)
1058 /* Can afford to be brutal with the _extends initializer.
1059 The derived type can get lost because it is PRIVATE
1060 but it is not usage constrained by the standard. */
1061 cons
->expr
->ts
= comp
->ts
;
1064 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1065 gfc_error ("The element in the structure constructor at %L, "
1066 "for pointer component '%s', is %s but should be %s",
1067 &cons
->expr
->where
, comp
->name
,
1068 gfc_basic_typename (cons
->expr
->ts
.type
),
1069 gfc_basic_typename (comp
->ts
.type
));
1071 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1074 /* For strings, the length of the constructor should be the same as
1075 the one of the structure, ensure this if the lengths are known at
1076 compile time and when we are dealing with PARAMETER or structure
1078 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1079 && comp
->ts
.u
.cl
->length
1080 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1081 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1082 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1083 && cons
->expr
->rank
!= 0
1084 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1085 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1087 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1088 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1090 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1091 to make use of the gfc_resolve_character_array_constructor
1092 machinery. The expression is later simplified away to
1093 an array of string literals. */
1094 gfc_expr
*para
= cons
->expr
;
1095 cons
->expr
= gfc_get_expr ();
1096 cons
->expr
->ts
= para
->ts
;
1097 cons
->expr
->where
= para
->where
;
1098 cons
->expr
->expr_type
= EXPR_ARRAY
;
1099 cons
->expr
->rank
= para
->rank
;
1100 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1101 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1102 para
, &cons
->expr
->where
);
1104 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1107 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1108 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1110 gfc_charlen
*cl
, *cl2
;
1113 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1115 if (cl
== cons
->expr
->ts
.u
.cl
)
1123 cl2
->next
= cl
->next
;
1125 gfc_free_expr (cl
->length
);
1129 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1130 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1131 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1132 gfc_resolve_character_array_constructor (cons
->expr
);
1136 if (cons
->expr
->expr_type
== EXPR_NULL
1137 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1138 || comp
->attr
.proc_pointer
1139 || (comp
->ts
.type
== BT_CLASS
1140 && (CLASS_DATA (comp
)->attr
.class_pointer
1141 || CLASS_DATA (comp
)->attr
.allocatable
))))
1144 gfc_error ("The NULL in the structure constructor at %L is "
1145 "being applied to component '%s', which is neither "
1146 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1150 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1152 /* Check procedure pointer interface. */
1153 gfc_symbol
*s2
= NULL
;
1158 if (gfc_is_proc_ptr_comp (cons
->expr
, &c2
))
1160 s2
= c2
->ts
.interface
;
1163 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1165 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1166 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1168 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1170 s2
= cons
->expr
->symtree
->n
.sym
;
1171 name
= cons
->expr
->symtree
->n
.sym
->name
;
1174 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1175 err
, sizeof (err
), NULL
, NULL
))
1177 gfc_error ("Interface mismatch for procedure-pointer component "
1178 "'%s' in structure constructor at %L: %s",
1179 comp
->name
, &cons
->expr
->where
, err
);
1184 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1185 || cons
->expr
->expr_type
== EXPR_NULL
)
1188 a
= gfc_expr_attr (cons
->expr
);
1190 if (!a
.pointer
&& !a
.target
)
1193 gfc_error ("The element in the structure constructor at %L, "
1194 "for pointer component '%s' should be a POINTER or "
1195 "a TARGET", &cons
->expr
->where
, comp
->name
);
1200 /* F08:C461. Additional checks for pointer initialization. */
1204 gfc_error ("Pointer initialization target at %L "
1205 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1210 gfc_error ("Pointer initialization target at %L "
1211 "must have the SAVE attribute", &cons
->expr
->where
);
1215 /* F2003, C1272 (3). */
1216 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1217 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1218 || gfc_is_coindexed (cons
->expr
)))
1221 gfc_error ("Invalid expression in the structure constructor for "
1222 "pointer component '%s' at %L in PURE procedure",
1223 comp
->name
, &cons
->expr
->where
);
1226 if (gfc_implicit_pure (NULL
)
1227 && cons
->expr
->expr_type
== EXPR_VARIABLE
1228 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1229 || gfc_is_coindexed (cons
->expr
)))
1230 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1238 /****************** Expression name resolution ******************/
1240 /* Returns 0 if a symbol was not declared with a type or
1241 attribute declaration statement, nonzero otherwise. */
1244 was_declared (gfc_symbol
*sym
)
1250 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1253 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1254 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1255 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1256 || a
.asynchronous
|| a
.codimension
)
1263 /* Determine if a symbol is generic or not. */
1266 generic_sym (gfc_symbol
*sym
)
1270 if (sym
->attr
.generic
||
1271 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1274 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1277 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1284 return generic_sym (s
);
1291 /* Determine if a symbol is specific or not. */
1294 specific_sym (gfc_symbol
*sym
)
1298 if (sym
->attr
.if_source
== IFSRC_IFBODY
1299 || sym
->attr
.proc
== PROC_MODULE
1300 || sym
->attr
.proc
== PROC_INTERNAL
1301 || sym
->attr
.proc
== PROC_ST_FUNCTION
1302 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1303 || sym
->attr
.external
)
1306 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1309 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1311 return (s
== NULL
) ? 0 : specific_sym (s
);
1315 /* Figure out if the procedure is specific, generic or unknown. */
1318 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1322 procedure_kind (gfc_symbol
*sym
)
1324 if (generic_sym (sym
))
1325 return PTYPE_GENERIC
;
1327 if (specific_sym (sym
))
1328 return PTYPE_SPECIFIC
;
1330 return PTYPE_UNKNOWN
;
1333 /* Check references to assumed size arrays. The flag need_full_assumed_size
1334 is nonzero when matching actual arguments. */
1336 static int need_full_assumed_size
= 0;
1339 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1341 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1344 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1345 What should it be? */
1346 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1347 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1348 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1350 gfc_error ("The upper bound in the last dimension must "
1351 "appear in the reference to the assumed size "
1352 "array '%s' at %L", sym
->name
, &e
->where
);
1359 /* Look for bad assumed size array references in argument expressions
1360 of elemental and array valued intrinsic procedures. Since this is
1361 called from procedure resolution functions, it only recurses at
1365 resolve_assumed_size_actual (gfc_expr
*e
)
1370 switch (e
->expr_type
)
1373 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1378 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1379 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1390 /* Check a generic procedure, passed as an actual argument, to see if
1391 there is a matching specific name. If none, it is an error, and if
1392 more than one, the reference is ambiguous. */
1394 count_specific_procs (gfc_expr
*e
)
1401 sym
= e
->symtree
->n
.sym
;
1403 for (p
= sym
->generic
; p
; p
= p
->next
)
1404 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1406 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1412 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1416 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1417 "argument at %L", sym
->name
, &e
->where
);
1423 /* See if a call to sym could possibly be a not allowed RECURSION because of
1424 a missing RECURSIVE declaration. This means that either sym is the current
1425 context itself, or sym is the parent of a contained procedure calling its
1426 non-RECURSIVE containing procedure.
1427 This also works if sym is an ENTRY. */
1430 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1432 gfc_symbol
* proc_sym
;
1433 gfc_symbol
* context_proc
;
1434 gfc_namespace
* real_context
;
1436 if (sym
->attr
.flavor
== FL_PROGRAM
1437 || sym
->attr
.flavor
== FL_DERIVED
)
1440 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1442 /* If we've got an ENTRY, find real procedure. */
1443 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1444 proc_sym
= sym
->ns
->entries
->sym
;
1448 /* If sym is RECURSIVE, all is well of course. */
1449 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1452 /* Find the context procedure's "real" symbol if it has entries.
1453 We look for a procedure symbol, so recurse on the parents if we don't
1454 find one (like in case of a BLOCK construct). */
1455 for (real_context
= context
; ; real_context
= real_context
->parent
)
1457 /* We should find something, eventually! */
1458 gcc_assert (real_context
);
1460 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1461 : real_context
->proc_name
);
1463 /* In some special cases, there may not be a proc_name, like for this
1465 real(bad_kind()) function foo () ...
1466 when checking the call to bad_kind ().
1467 In these cases, we simply return here and assume that the
1472 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1476 /* A call from sym's body to itself is recursion, of course. */
1477 if (context_proc
== proc_sym
)
1480 /* The same is true if context is a contained procedure and sym the
1482 if (context_proc
->attr
.contained
)
1484 gfc_symbol
* parent_proc
;
1486 gcc_assert (context
->parent
);
1487 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1488 : context
->parent
->proc_name
);
1490 if (parent_proc
== proc_sym
)
1498 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1499 its typespec and formal argument list. */
1502 resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1504 gfc_intrinsic_sym
* isym
= NULL
;
1510 /* Already resolved. */
1511 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1514 /* We already know this one is an intrinsic, so we don't call
1515 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1516 gfc_find_subroutine directly to check whether it is a function or
1519 if (sym
->intmod_sym_id
)
1520 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1521 else if (!sym
->attr
.subroutine
)
1522 isym
= gfc_find_function (sym
->name
);
1526 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1527 && !sym
->attr
.implicit_type
)
1528 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1529 " ignored", sym
->name
, &sym
->declared_at
);
1531 if (!sym
->attr
.function
&&
1532 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1537 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1539 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1541 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1542 " specifier", sym
->name
, &sym
->declared_at
);
1546 if (!sym
->attr
.subroutine
&&
1547 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1552 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1557 gfc_copy_formal_args_intr (sym
, isym
);
1559 /* Check it is actually available in the standard settings. */
1560 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1563 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1564 " available in the current standard settings but %s. Use"
1565 " an appropriate -std=* option or enable -fall-intrinsics"
1566 " in order to use it.",
1567 sym
->name
, &sym
->declared_at
, symstd
);
1575 /* Resolve a procedure expression, like passing it to a called procedure or as
1576 RHS for a procedure pointer assignment. */
1579 resolve_procedure_expression (gfc_expr
* expr
)
1583 if (expr
->expr_type
!= EXPR_VARIABLE
)
1585 gcc_assert (expr
->symtree
);
1587 sym
= expr
->symtree
->n
.sym
;
1589 if (sym
->attr
.intrinsic
)
1590 resolve_intrinsic (sym
, &expr
->where
);
1592 if (sym
->attr
.flavor
!= FL_PROCEDURE
1593 || (sym
->attr
.function
&& sym
->result
== sym
))
1596 /* A non-RECURSIVE procedure that is used as procedure expression within its
1597 own body is in danger of being called recursively. */
1598 if (is_illegal_recursion (sym
, gfc_current_ns
))
1599 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1600 " itself recursively. Declare it RECURSIVE or use"
1601 " -frecursive", sym
->name
, &expr
->where
);
1607 /* Resolve an actual argument list. Most of the time, this is just
1608 resolving the expressions in the list.
1609 The exception is that we sometimes have to decide whether arguments
1610 that look like procedure arguments are really simple variable
1614 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1615 bool no_formal_args
)
1618 gfc_symtree
*parent_st
;
1620 int save_need_full_assumed_size
;
1621 gfc_try return_value
= FAILURE
;
1622 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1625 first_actual_arg
= true;
1627 for (; arg
; arg
= arg
->next
)
1632 /* Check the label is a valid branching target. */
1635 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1637 gfc_error ("Label %d referenced at %L is never defined",
1638 arg
->label
->value
, &arg
->label
->where
);
1642 first_actual_arg
= false;
1646 if (e
->expr_type
== EXPR_VARIABLE
1647 && e
->symtree
->n
.sym
->attr
.generic
1649 && count_specific_procs (e
) != 1)
1652 if (e
->ts
.type
!= BT_PROCEDURE
)
1654 save_need_full_assumed_size
= need_full_assumed_size
;
1655 if (e
->expr_type
!= EXPR_VARIABLE
)
1656 need_full_assumed_size
= 0;
1657 if (gfc_resolve_expr (e
) != SUCCESS
)
1659 need_full_assumed_size
= save_need_full_assumed_size
;
1663 /* See if the expression node should really be a variable reference. */
1665 sym
= e
->symtree
->n
.sym
;
1667 if (sym
->attr
.flavor
== FL_PROCEDURE
1668 || sym
->attr
.intrinsic
1669 || sym
->attr
.external
)
1673 /* If a procedure is not already determined to be something else
1674 check if it is intrinsic. */
1675 if (!sym
->attr
.intrinsic
1676 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1677 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1678 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1679 sym
->attr
.intrinsic
= 1;
1681 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1683 gfc_error ("Statement function '%s' at %L is not allowed as an "
1684 "actual argument", sym
->name
, &e
->where
);
1687 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1688 sym
->attr
.subroutine
);
1689 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1691 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1692 "actual argument", sym
->name
, &e
->where
);
1695 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1696 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1698 if (gfc_notify_std (GFC_STD_F2008
,
1699 "Internal procedure '%s' is"
1700 " used as actual argument at %L",
1701 sym
->name
, &e
->where
) == FAILURE
)
1705 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1707 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1708 "allowed as an actual argument at %L", sym
->name
,
1712 /* Check if a generic interface has a specific procedure
1713 with the same name before emitting an error. */
1714 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1717 /* Just in case a specific was found for the expression. */
1718 sym
= e
->symtree
->n
.sym
;
1720 /* If the symbol is the function that names the current (or
1721 parent) scope, then we really have a variable reference. */
1723 if (gfc_is_function_return_value (sym
, sym
->ns
))
1726 /* If all else fails, see if we have a specific intrinsic. */
1727 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1729 gfc_intrinsic_sym
*isym
;
1731 isym
= gfc_find_function (sym
->name
);
1732 if (isym
== NULL
|| !isym
->specific
)
1734 gfc_error ("Unable to find a specific INTRINSIC procedure "
1735 "for the reference '%s' at %L", sym
->name
,
1740 sym
->attr
.intrinsic
= 1;
1741 sym
->attr
.function
= 1;
1744 if (gfc_resolve_expr (e
) == FAILURE
)
1749 /* See if the name is a module procedure in a parent unit. */
1751 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1754 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1756 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1760 if (parent_st
== NULL
)
1763 sym
= parent_st
->n
.sym
;
1764 e
->symtree
= parent_st
; /* Point to the right thing. */
1766 if (sym
->attr
.flavor
== FL_PROCEDURE
1767 || sym
->attr
.intrinsic
1768 || sym
->attr
.external
)
1770 if (gfc_resolve_expr (e
) == FAILURE
)
1776 e
->expr_type
= EXPR_VARIABLE
;
1778 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1779 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1780 && CLASS_DATA (sym
)->as
))
1782 e
->rank
= sym
->ts
.type
== BT_CLASS
1783 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1784 e
->ref
= gfc_get_ref ();
1785 e
->ref
->type
= REF_ARRAY
;
1786 e
->ref
->u
.ar
.type
= AR_FULL
;
1787 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1788 ? CLASS_DATA (sym
)->as
: sym
->as
;
1791 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1792 primary.c (match_actual_arg). If above code determines that it
1793 is a variable instead, it needs to be resolved as it was not
1794 done at the beginning of this function. */
1795 save_need_full_assumed_size
= need_full_assumed_size
;
1796 if (e
->expr_type
!= EXPR_VARIABLE
)
1797 need_full_assumed_size
= 0;
1798 if (gfc_resolve_expr (e
) != SUCCESS
)
1800 need_full_assumed_size
= save_need_full_assumed_size
;
1803 /* Check argument list functions %VAL, %LOC and %REF. There is
1804 nothing to do for %REF. */
1805 if (arg
->name
&& arg
->name
[0] == '%')
1807 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1809 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1811 gfc_error ("By-value argument at %L is not of numeric "
1818 gfc_error ("By-value argument at %L cannot be an array or "
1819 "an array section", &e
->where
);
1823 /* Intrinsics are still PROC_UNKNOWN here. However,
1824 since same file external procedures are not resolvable
1825 in gfortran, it is a good deal easier to leave them to
1827 if (ptype
!= PROC_UNKNOWN
1828 && ptype
!= PROC_DUMMY
1829 && ptype
!= PROC_EXTERNAL
1830 && ptype
!= PROC_MODULE
)
1832 gfc_error ("By-value argument at %L is not allowed "
1833 "in this context", &e
->where
);
1838 /* Statement functions have already been excluded above. */
1839 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1840 && e
->ts
.type
== BT_PROCEDURE
)
1842 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1844 gfc_error ("Passing internal procedure at %L by location "
1845 "not allowed", &e
->where
);
1851 /* Fortran 2008, C1237. */
1852 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1853 && gfc_has_ultimate_pointer (e
))
1855 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1856 "component", &e
->where
);
1860 first_actual_arg
= false;
1863 return_value
= SUCCESS
;
1866 actual_arg
= actual_arg_sav
;
1867 first_actual_arg
= first_actual_arg_sav
;
1869 return return_value
;
1873 /* Do the checks of the actual argument list that are specific to elemental
1874 procedures. If called with c == NULL, we have a function, otherwise if
1875 expr == NULL, we have a subroutine. */
1878 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1880 gfc_actual_arglist
*arg0
;
1881 gfc_actual_arglist
*arg
;
1882 gfc_symbol
*esym
= NULL
;
1883 gfc_intrinsic_sym
*isym
= NULL
;
1885 gfc_intrinsic_arg
*iformal
= NULL
;
1886 gfc_formal_arglist
*eformal
= NULL
;
1887 bool formal_optional
= false;
1888 bool set_by_optional
= false;
1892 /* Is this an elemental procedure? */
1893 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1895 if (expr
->value
.function
.esym
!= NULL
1896 && expr
->value
.function
.esym
->attr
.elemental
)
1898 arg0
= expr
->value
.function
.actual
;
1899 esym
= expr
->value
.function
.esym
;
1901 else if (expr
->value
.function
.isym
!= NULL
1902 && expr
->value
.function
.isym
->elemental
)
1904 arg0
= expr
->value
.function
.actual
;
1905 isym
= expr
->value
.function
.isym
;
1910 else if (c
&& c
->ext
.actual
!= NULL
)
1912 arg0
= c
->ext
.actual
;
1914 if (c
->resolved_sym
)
1915 esym
= c
->resolved_sym
;
1917 esym
= c
->symtree
->n
.sym
;
1920 if (!esym
->attr
.elemental
)
1926 /* The rank of an elemental is the rank of its array argument(s). */
1927 for (arg
= arg0
; arg
; arg
= arg
->next
)
1929 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
1931 rank
= arg
->expr
->rank
;
1932 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1933 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1934 set_by_optional
= true;
1936 /* Function specific; set the result rank and shape. */
1940 if (!expr
->shape
&& arg
->expr
->shape
)
1942 expr
->shape
= gfc_get_shape (rank
);
1943 for (i
= 0; i
< rank
; i
++)
1944 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1951 /* If it is an array, it shall not be supplied as an actual argument
1952 to an elemental procedure unless an array of the same rank is supplied
1953 as an actual argument corresponding to a nonoptional dummy argument of
1954 that elemental procedure(12.4.1.5). */
1955 formal_optional
= false;
1957 iformal
= isym
->formal
;
1959 eformal
= esym
->formal
;
1961 for (arg
= arg0
; arg
; arg
= arg
->next
)
1965 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1966 formal_optional
= true;
1967 eformal
= eformal
->next
;
1969 else if (isym
&& iformal
)
1971 if (iformal
->optional
)
1972 formal_optional
= true;
1973 iformal
= iformal
->next
;
1976 formal_optional
= true;
1978 if (pedantic
&& arg
->expr
!= NULL
1979 && arg
->expr
->expr_type
== EXPR_VARIABLE
1980 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1983 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1984 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1986 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1987 "MISSING, it cannot be the actual argument of an "
1988 "ELEMENTAL procedure unless there is a non-optional "
1989 "argument with the same rank (12.4.1.5)",
1990 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1994 for (arg
= arg0
; arg
; arg
= arg
->next
)
1996 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1999 /* Being elemental, the last upper bound of an assumed size array
2000 argument must be present. */
2001 if (resolve_assumed_size_actual (arg
->expr
))
2004 /* Elemental procedure's array actual arguments must conform. */
2007 if (gfc_check_conformance (arg
->expr
, e
,
2008 "elemental procedure") == FAILURE
)
2015 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2016 is an array, the intent inout/out variable needs to be also an array. */
2017 if (rank
> 0 && esym
&& expr
== NULL
)
2018 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2019 arg
= arg
->next
, eformal
= eformal
->next
)
2020 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2021 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2022 && arg
->expr
&& arg
->expr
->rank
== 0)
2024 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2025 "ELEMENTAL subroutine '%s' is a scalar, but another "
2026 "actual argument is an array", &arg
->expr
->where
,
2027 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2028 : "INOUT", eformal
->sym
->name
, esym
->name
);
2035 /* This function does the checking of references to global procedures
2036 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2037 77 and 95 standards. It checks for a gsymbol for the name, making
2038 one if it does not already exist. If it already exists, then the
2039 reference being resolved must correspond to the type of gsymbol.
2040 Otherwise, the new symbol is equipped with the attributes of the
2041 reference. The corresponding code that is called in creating
2042 global entities is parse.c.
2044 In addition, for all but -std=legacy, the gsymbols are used to
2045 check the interfaces of external procedures from the same file.
2046 The namespace of the gsymbol is resolved and then, once this is
2047 done the interface is checked. */
2051 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2053 if (!gsym_ns
->proc_name
->attr
.recursive
)
2056 if (sym
->ns
== gsym_ns
)
2059 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2066 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2068 if (gsym_ns
->entries
)
2070 gfc_entry_list
*entry
= gsym_ns
->entries
;
2072 for (; entry
; entry
= entry
->next
)
2074 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2076 if (strcmp (gsym_ns
->proc_name
->name
,
2077 sym
->ns
->proc_name
->name
) == 0)
2081 && strcmp (gsym_ns
->proc_name
->name
,
2082 sym
->ns
->parent
->proc_name
->name
) == 0)
2091 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2092 gfc_actual_arglist
**actual
, int sub
)
2096 enum gfc_symbol_type type
;
2098 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2100 gsym
= gfc_get_gsymbol (sym
->name
);
2102 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2103 gfc_global_used (gsym
, where
);
2105 if (gfc_option
.flag_whole_file
2106 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2107 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2108 && gsym
->type
!= GSYM_UNKNOWN
2110 && gsym
->ns
->resolved
!= -1
2111 && gsym
->ns
->proc_name
2112 && not_in_recursive (sym
, gsym
->ns
)
2113 && not_entry_self_reference (sym
, gsym
->ns
))
2115 gfc_symbol
*def_sym
;
2117 /* Resolve the gsymbol namespace if needed. */
2118 if (!gsym
->ns
->resolved
)
2120 gfc_dt_list
*old_dt_list
;
2121 struct gfc_omp_saved_state old_omp_state
;
2123 /* Stash away derived types so that the backend_decls do not
2125 old_dt_list
= gfc_derived_types
;
2126 gfc_derived_types
= NULL
;
2127 /* And stash away openmp state. */
2128 gfc_omp_save_and_clear_state (&old_omp_state
);
2130 gfc_resolve (gsym
->ns
);
2132 /* Store the new derived types with the global namespace. */
2133 if (gfc_derived_types
)
2134 gsym
->ns
->derived_types
= gfc_derived_types
;
2136 /* Restore the derived types of this namespace. */
2137 gfc_derived_types
= old_dt_list
;
2138 /* And openmp state. */
2139 gfc_omp_restore_state (&old_omp_state
);
2142 /* Make sure that translation for the gsymbol occurs before
2143 the procedure currently being resolved. */
2144 ns
= gfc_global_ns_list
;
2145 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2147 if (ns
->sibling
== gsym
->ns
)
2149 ns
->sibling
= gsym
->ns
->sibling
;
2150 gsym
->ns
->sibling
= gfc_global_ns_list
;
2151 gfc_global_ns_list
= gsym
->ns
;
2156 def_sym
= gsym
->ns
->proc_name
;
2157 if (def_sym
->attr
.entry_master
)
2159 gfc_entry_list
*entry
;
2160 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2161 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2163 def_sym
= entry
->sym
;
2168 /* Differences in constant character lengths. */
2169 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2171 long int l1
= 0, l2
= 0;
2172 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2173 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2176 && cl1
->length
!= NULL
2177 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2178 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2181 && cl2
->length
!= NULL
2182 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2183 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2185 if (l1
&& l2
&& l1
!= l2
)
2186 gfc_error ("Character length mismatch in return type of "
2187 "function '%s' at %L (%ld/%ld)", sym
->name
,
2188 &sym
->declared_at
, l1
, l2
);
2191 /* Type mismatch of function return type and expected type. */
2192 if (sym
->attr
.function
2193 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2194 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2195 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2196 gfc_typename (&def_sym
->ts
));
2198 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2200 gfc_formal_arglist
*arg
= def_sym
->formal
;
2201 for ( ; arg
; arg
= arg
->next
)
2204 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2205 else if (arg
->sym
->attr
.allocatable
2206 || arg
->sym
->attr
.asynchronous
2207 || arg
->sym
->attr
.optional
2208 || arg
->sym
->attr
.pointer
2209 || arg
->sym
->attr
.target
2210 || arg
->sym
->attr
.value
2211 || arg
->sym
->attr
.volatile_
)
2213 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2214 "has an attribute that requires an explicit "
2215 "interface for this procedure", arg
->sym
->name
,
2216 sym
->name
, &sym
->declared_at
);
2219 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2220 else if (arg
->sym
&& arg
->sym
->as
2221 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2223 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2224 "argument '%s' must have an explicit interface",
2225 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2228 /* TS 29113, 6.2. */
2229 else if (arg
->sym
&& arg
->sym
->as
2230 && arg
->sym
->as
->type
== AS_ASSUMED_RANK
)
2232 gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
2233 "argument '%s' must have an explicit interface",
2234 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2237 /* F2008, 12.4.2.2 (2c) */
2238 else if (arg
->sym
->attr
.codimension
)
2240 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2241 "'%s' must have an explicit interface",
2242 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2245 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2246 else if (false) /* TODO: is a parametrized derived type */
2248 gfc_error ("Procedure '%s' at %L with parametrized derived "
2249 "type argument '%s' must have an explicit "
2250 "interface", sym
->name
, &sym
->declared_at
,
2254 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2255 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2257 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2258 "argument '%s' must have an explicit interface",
2259 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2262 /* As assumed-type is unlimited polymorphic (cf. above).
2263 See also TS 29113, Note 6.1. */
2264 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2266 gfc_error ("Procedure '%s' at %L with assumed-type dummy "
2267 "argument '%s' must have an explicit interface",
2268 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2273 if (def_sym
->attr
.function
)
2275 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2276 if (def_sym
->as
&& def_sym
->as
->rank
2277 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2278 gfc_error ("The reference to function '%s' at %L either needs an "
2279 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2282 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2283 if ((def_sym
->result
->attr
.pointer
2284 || def_sym
->result
->attr
.allocatable
)
2285 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2286 || def_sym
->result
->attr
.pointer
2287 != sym
->result
->attr
.pointer
2288 || def_sym
->result
->attr
.allocatable
2289 != sym
->result
->attr
.allocatable
))
2290 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2291 "result must have an explicit interface", sym
->name
,
2294 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2295 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2296 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2298 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2300 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2301 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2303 gfc_error ("Nonconstant character-length function '%s' at %L "
2304 "must have an explicit interface", sym
->name
,
2310 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2311 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2313 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2314 "interface", sym
->name
, &sym
->declared_at
);
2317 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2318 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2320 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2321 "an explicit interface", sym
->name
, &sym
->declared_at
);
2324 if (gfc_option
.flag_whole_file
== 1
2325 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2326 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2327 gfc_errors_to_warnings (1);
2329 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2330 gfc_procedure_use (def_sym
, actual
, where
);
2332 gfc_errors_to_warnings (0);
2335 if (gsym
->type
== GSYM_UNKNOWN
)
2338 gsym
->where
= *where
;
2345 /************* Function resolution *************/
2347 /* Resolve a function call known to be generic.
2348 Section 14.1.2.4.1. */
2351 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2355 if (sym
->attr
.generic
)
2357 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2360 expr
->value
.function
.name
= s
->name
;
2361 expr
->value
.function
.esym
= s
;
2363 if (s
->ts
.type
!= BT_UNKNOWN
)
2365 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2366 expr
->ts
= s
->result
->ts
;
2369 expr
->rank
= s
->as
->rank
;
2370 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2371 expr
->rank
= s
->result
->as
->rank
;
2373 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2378 /* TODO: Need to search for elemental references in generic
2382 if (sym
->attr
.intrinsic
)
2383 return gfc_intrinsic_func_interface (expr
, 0);
2390 resolve_generic_f (gfc_expr
*expr
)
2394 gfc_interface
*intr
= NULL
;
2396 sym
= expr
->symtree
->n
.sym
;
2400 m
= resolve_generic_f0 (expr
, sym
);
2403 else if (m
== MATCH_ERROR
)
2408 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2409 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2412 if (sym
->ns
->parent
== NULL
)
2414 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2418 if (!generic_sym (sym
))
2422 /* Last ditch attempt. See if the reference is to an intrinsic
2423 that possesses a matching interface. 14.1.2.4 */
2424 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2426 gfc_error ("There is no specific function for the generic '%s' "
2427 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2433 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2436 return resolve_structure_cons (expr
, 0);
2439 m
= gfc_intrinsic_func_interface (expr
, 0);
2444 gfc_error ("Generic function '%s' at %L is not consistent with a "
2445 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2452 /* Resolve a function call known to be specific. */
2455 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2459 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2461 if (sym
->attr
.dummy
)
2463 sym
->attr
.proc
= PROC_DUMMY
;
2467 sym
->attr
.proc
= PROC_EXTERNAL
;
2471 if (sym
->attr
.proc
== PROC_MODULE
2472 || sym
->attr
.proc
== PROC_ST_FUNCTION
2473 || sym
->attr
.proc
== PROC_INTERNAL
)
2476 if (sym
->attr
.intrinsic
)
2478 m
= gfc_intrinsic_func_interface (expr
, 1);
2482 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2483 "with an intrinsic", sym
->name
, &expr
->where
);
2491 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2494 expr
->ts
= sym
->result
->ts
;
2497 expr
->value
.function
.name
= sym
->name
;
2498 expr
->value
.function
.esym
= sym
;
2499 if (sym
->as
!= NULL
)
2500 expr
->rank
= sym
->as
->rank
;
2507 resolve_specific_f (gfc_expr
*expr
)
2512 sym
= expr
->symtree
->n
.sym
;
2516 m
= resolve_specific_f0 (sym
, expr
);
2519 if (m
== MATCH_ERROR
)
2522 if (sym
->ns
->parent
== NULL
)
2525 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2531 gfc_error ("Unable to resolve the specific function '%s' at %L",
2532 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2538 /* Resolve a procedure call not known to be generic nor specific. */
2541 resolve_unknown_f (gfc_expr
*expr
)
2546 sym
= expr
->symtree
->n
.sym
;
2548 if (sym
->attr
.dummy
)
2550 sym
->attr
.proc
= PROC_DUMMY
;
2551 expr
->value
.function
.name
= sym
->name
;
2555 /* See if we have an intrinsic function reference. */
2557 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2559 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2564 /* The reference is to an external name. */
2566 sym
->attr
.proc
= PROC_EXTERNAL
;
2567 expr
->value
.function
.name
= sym
->name
;
2568 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2570 if (sym
->as
!= NULL
)
2571 expr
->rank
= sym
->as
->rank
;
2573 /* Type of the expression is either the type of the symbol or the
2574 default type of the symbol. */
2577 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2579 if (sym
->ts
.type
!= BT_UNKNOWN
)
2583 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2585 if (ts
->type
== BT_UNKNOWN
)
2587 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2588 sym
->name
, &expr
->where
);
2599 /* Return true, if the symbol is an external procedure. */
2601 is_external_proc (gfc_symbol
*sym
)
2603 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2604 && !(sym
->attr
.intrinsic
2605 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2606 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2607 && !sym
->attr
.proc_pointer
2608 && !sym
->attr
.use_assoc
2616 /* Figure out if a function reference is pure or not. Also set the name
2617 of the function for a potential error message. Return nonzero if the
2618 function is PURE, zero if not. */
2620 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2623 pure_function (gfc_expr
*e
, const char **name
)
2629 if (e
->symtree
!= NULL
2630 && e
->symtree
->n
.sym
!= NULL
2631 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2632 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2634 if (e
->value
.function
.esym
)
2636 pure
= gfc_pure (e
->value
.function
.esym
);
2637 *name
= e
->value
.function
.esym
->name
;
2639 else if (e
->value
.function
.isym
)
2641 pure
= e
->value
.function
.isym
->pure
2642 || e
->value
.function
.isym
->elemental
;
2643 *name
= e
->value
.function
.isym
->name
;
2647 /* Implicit functions are not pure. */
2649 *name
= e
->value
.function
.name
;
2657 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2658 int *f ATTRIBUTE_UNUSED
)
2662 /* Don't bother recursing into other statement functions
2663 since they will be checked individually for purity. */
2664 if (e
->expr_type
!= EXPR_FUNCTION
2666 || e
->symtree
->n
.sym
== sym
2667 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2670 return pure_function (e
, &name
) ? false : true;
2675 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2677 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2682 is_scalar_expr_ptr (gfc_expr
*expr
)
2684 gfc_try retval
= SUCCESS
;
2689 /* See if we have a gfc_ref, which means we have a substring, array
2690 reference, or a component. */
2691 if (expr
->ref
!= NULL
)
2694 while (ref
->next
!= NULL
)
2700 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2701 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2706 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2708 else if (ref
->u
.ar
.type
== AR_FULL
)
2710 /* The user can give a full array if the array is of size 1. */
2711 if (ref
->u
.ar
.as
!= NULL
2712 && ref
->u
.ar
.as
->rank
== 1
2713 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2714 && ref
->u
.ar
.as
->lower
[0] != NULL
2715 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2716 && ref
->u
.ar
.as
->upper
[0] != NULL
2717 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2719 /* If we have a character string, we need to check if
2720 its length is one. */
2721 if (expr
->ts
.type
== BT_CHARACTER
)
2723 if (expr
->ts
.u
.cl
== NULL
2724 || expr
->ts
.u
.cl
->length
== NULL
2725 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2731 /* We have constant lower and upper bounds. If the
2732 difference between is 1, it can be considered a
2734 FIXME: Use gfc_dep_compare_expr instead. */
2735 start
= (int) mpz_get_si
2736 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2737 end
= (int) mpz_get_si
2738 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2739 if (end
- start
+ 1 != 1)
2754 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2756 /* Character string. Make sure it's of length 1. */
2757 if (expr
->ts
.u
.cl
== NULL
2758 || expr
->ts
.u
.cl
->length
== NULL
2759 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2762 else if (expr
->rank
!= 0)
2769 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2770 and, in the case of c_associated, set the binding label based on
2774 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2775 gfc_symbol
**new_sym
)
2777 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2778 int optional_arg
= 0;
2779 gfc_try retval
= SUCCESS
;
2780 gfc_symbol
*args_sym
;
2781 gfc_typespec
*arg_ts
;
2782 symbol_attribute arg_attr
;
2784 if (args
->expr
->expr_type
== EXPR_CONSTANT
2785 || args
->expr
->expr_type
== EXPR_OP
2786 || args
->expr
->expr_type
== EXPR_NULL
)
2788 gfc_error ("Argument to '%s' at %L is not a variable",
2789 sym
->name
, &(args
->expr
->where
));
2793 args_sym
= args
->expr
->symtree
->n
.sym
;
2795 /* The typespec for the actual arg should be that stored in the expr
2796 and not necessarily that of the expr symbol (args_sym), because
2797 the actual expression could be a part-ref of the expr symbol. */
2798 arg_ts
= &(args
->expr
->ts
);
2799 arg_attr
= gfc_expr_attr (args
->expr
);
2801 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2803 /* If the user gave two args then they are providing something for
2804 the optional arg (the second cptr). Therefore, set the name and
2805 binding label to the c_associated for two cptrs. Otherwise,
2806 set c_associated to expect one cptr. */
2810 sprintf (name
, "%s_2", sym
->name
);
2816 sprintf (name
, "%s_1", sym
->name
);
2820 /* Get a new symbol for the version of c_associated that
2822 *new_sym
= get_iso_c_sym (sym
, name
, NULL
, optional_arg
);
2824 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2825 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2827 sprintf (name
, "%s", sym
->name
);
2829 /* Error check the call. */
2830 if (args
->next
!= NULL
)
2832 gfc_error_now ("More actual than formal arguments in '%s' "
2833 "call at %L", name
, &(args
->expr
->where
));
2836 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2841 /* Make sure we have either the target or pointer attribute. */
2842 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2844 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2845 "a TARGET or an associated pointer",
2847 sym
->name
, &(args
->expr
->where
));
2851 if (gfc_is_coindexed (args
->expr
))
2853 gfc_error_now ("Coindexed argument not permitted"
2854 " in '%s' call at %L", name
,
2855 &(args
->expr
->where
));
2859 /* Follow references to make sure there are no array
2861 seen_section
= false;
2863 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2865 if (ref
->type
== REF_ARRAY
)
2867 if (ref
->u
.ar
.type
== AR_SECTION
)
2868 seen_section
= true;
2870 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2873 for (r
= ref
->next
; r
; r
=r
->next
)
2874 if (r
->type
== REF_COMPONENT
)
2876 gfc_error_now ("Array section not permitted"
2877 " in '%s' call at %L", name
,
2878 &(args
->expr
->where
));
2886 if (seen_section
&& retval
== SUCCESS
)
2887 gfc_warning ("Array section in '%s' call at %L", name
,
2888 &(args
->expr
->where
));
2890 /* See if we have interoperable type and type param. */
2891 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2892 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2894 if (args_sym
->attr
.target
== 1)
2896 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2897 has the target attribute and is interoperable. */
2898 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2899 allocatable variable that has the TARGET attribute and
2900 is not an array of zero size. */
2901 if (args_sym
->attr
.allocatable
== 1)
2903 if (args_sym
->attr
.dimension
!= 0
2904 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2906 gfc_error_now ("Allocatable variable '%s' used as a "
2907 "parameter to '%s' at %L must not be "
2908 "an array of zero size",
2909 args_sym
->name
, sym
->name
,
2910 &(args
->expr
->where
));
2916 /* A non-allocatable target variable with C
2917 interoperable type and type parameters must be
2919 if (args_sym
&& args_sym
->attr
.dimension
)
2921 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2923 gfc_error ("Assumed-shape array '%s' at %L "
2924 "cannot be an argument to the "
2925 "procedure '%s' because "
2926 "it is not C interoperable",
2928 &(args
->expr
->where
), sym
->name
);
2931 else if (args_sym
->as
->type
== AS_DEFERRED
)
2933 gfc_error ("Deferred-shape array '%s' at %L "
2934 "cannot be an argument to the "
2935 "procedure '%s' because "
2936 "it is not C interoperable",
2938 &(args
->expr
->where
), sym
->name
);
2943 /* Make sure it's not a character string. Arrays of
2944 any type should be ok if the variable is of a C
2945 interoperable type. */
2946 if (arg_ts
->type
== BT_CHARACTER
)
2947 if (arg_ts
->u
.cl
!= NULL
2948 && (arg_ts
->u
.cl
->length
== NULL
2949 || arg_ts
->u
.cl
->length
->expr_type
2952 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2954 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2956 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2957 "at %L must have a length of 1",
2958 args_sym
->name
, sym
->name
,
2959 &(args
->expr
->where
));
2964 else if (arg_attr
.pointer
2965 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2967 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2969 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2970 "associated scalar POINTER", args_sym
->name
,
2971 sym
->name
, &(args
->expr
->where
));
2977 /* The parameter is not required to be C interoperable. If it
2978 is not C interoperable, it must be a nonpolymorphic scalar
2979 with no length type parameters. It still must have either
2980 the pointer or target attribute, and it can be
2981 allocatable (but must be allocated when c_loc is called). */
2982 if (args
->expr
->rank
!= 0
2983 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2985 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2986 "scalar", args_sym
->name
, sym
->name
,
2987 &(args
->expr
->where
));
2990 else if (arg_ts
->type
== BT_CHARACTER
2991 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2993 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2994 "%L must have a length of 1",
2995 args_sym
->name
, sym
->name
,
2996 &(args
->expr
->where
));
2999 else if (arg_ts
->type
== BT_CLASS
)
3001 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
3002 "polymorphic", args_sym
->name
, sym
->name
,
3003 &(args
->expr
->where
));
3008 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
3010 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
3012 /* TODO: Update this error message to allow for procedure
3013 pointers once they are implemented. */
3014 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
3016 args_sym
->name
, sym
->name
,
3017 &(args
->expr
->where
));
3020 else if (args_sym
->attr
.is_bind_c
!= 1)
3022 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
3024 args_sym
->name
, sym
->name
,
3025 &(args
->expr
->where
));
3030 /* for c_loc/c_funloc, the new symbol is the same as the old one */
3035 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
3036 "iso_c_binding function: '%s'!\n", sym
->name
);
3043 /* Resolve a function call, which means resolving the arguments, then figuring
3044 out which entity the name refers to. */
3047 resolve_function (gfc_expr
*expr
)
3049 gfc_actual_arglist
*arg
;
3054 procedure_type p
= PROC_INTRINSIC
;
3055 bool no_formal_args
;
3059 sym
= expr
->symtree
->n
.sym
;
3061 /* If this is a procedure pointer component, it has already been resolved. */
3062 if (gfc_is_proc_ptr_comp (expr
, NULL
))
3065 if (sym
&& sym
->attr
.intrinsic
3066 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3069 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3071 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3075 /* If this ia a deferred TBP with an abstract interface (which may
3076 of course be referenced), expr->value.function.esym will be set. */
3077 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3079 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3080 sym
->name
, &expr
->where
);
3084 /* Switch off assumed size checking and do this again for certain kinds
3085 of procedure, once the procedure itself is resolved. */
3086 need_full_assumed_size
++;
3088 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3089 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3091 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3092 inquiry_argument
= true;
3093 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3095 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3096 p
, no_formal_args
) == FAILURE
)
3098 inquiry_argument
= false;
3102 inquiry_argument
= false;
3104 /* Need to setup the call to the correct c_associated, depending on
3105 the number of cptrs to user gives to compare. */
3106 if (sym
&& sym
->attr
.is_iso_c
== 1)
3108 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3112 /* Get the symtree for the new symbol (resolved func).
3113 the old one will be freed later, when it's no longer used. */
3114 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3117 /* Resume assumed_size checking. */
3118 need_full_assumed_size
--;
3120 /* If the procedure is external, check for usage. */
3121 if (sym
&& is_external_proc (sym
))
3122 resolve_global_procedure (sym
, &expr
->where
,
3123 &expr
->value
.function
.actual
, 0);
3125 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3127 && sym
->ts
.u
.cl
->length
== NULL
3129 && !sym
->ts
.deferred
3130 && expr
->value
.function
.esym
== NULL
3131 && !sym
->attr
.contained
)
3133 /* Internal procedures are taken care of in resolve_contained_fntype. */
3134 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3135 "be used at %L since it is not a dummy argument",
3136 sym
->name
, &expr
->where
);
3140 /* See if function is already resolved. */
3142 if (expr
->value
.function
.name
!= NULL
)
3144 if (expr
->ts
.type
== BT_UNKNOWN
)
3150 /* Apply the rules of section 14.1.2. */
3152 switch (procedure_kind (sym
))
3155 t
= resolve_generic_f (expr
);
3158 case PTYPE_SPECIFIC
:
3159 t
= resolve_specific_f (expr
);
3163 t
= resolve_unknown_f (expr
);
3167 gfc_internal_error ("resolve_function(): bad function type");
3171 /* If the expression is still a function (it might have simplified),
3172 then we check to see if we are calling an elemental function. */
3174 if (expr
->expr_type
!= EXPR_FUNCTION
)
3177 temp
= need_full_assumed_size
;
3178 need_full_assumed_size
= 0;
3180 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3183 if (omp_workshare_flag
3184 && expr
->value
.function
.esym
3185 && ! gfc_elemental (expr
->value
.function
.esym
))
3187 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3188 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3193 #define GENERIC_ID expr->value.function.isym->id
3194 else if (expr
->value
.function
.actual
!= NULL
3195 && expr
->value
.function
.isym
!= NULL
3196 && GENERIC_ID
!= GFC_ISYM_LBOUND
3197 && GENERIC_ID
!= GFC_ISYM_LEN
3198 && GENERIC_ID
!= GFC_ISYM_LOC
3199 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3201 /* Array intrinsics must also have the last upper bound of an
3202 assumed size array argument. UBOUND and SIZE have to be
3203 excluded from the check if the second argument is anything
3206 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3208 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3209 && arg
->next
!= NULL
&& arg
->next
->expr
)
3211 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3214 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3217 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3222 if (arg
->expr
!= NULL
3223 && arg
->expr
->rank
> 0
3224 && resolve_assumed_size_actual (arg
->expr
))
3230 need_full_assumed_size
= temp
;
3233 if (!pure_function (expr
, &name
) && name
)
3237 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3238 "FORALL %s", name
, &expr
->where
,
3239 forall_flag
== 2 ? "mask" : "block");
3242 else if (do_concurrent_flag
)
3244 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3245 "DO CONCURRENT %s", name
, &expr
->where
,
3246 do_concurrent_flag
== 2 ? "mask" : "block");
3249 else if (gfc_pure (NULL
))
3251 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3252 "procedure within a PURE procedure", name
, &expr
->where
);
3256 if (gfc_implicit_pure (NULL
))
3257 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3260 /* Functions without the RECURSIVE attribution are not allowed to
3261 * call themselves. */
3262 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3265 esym
= expr
->value
.function
.esym
;
3267 if (is_illegal_recursion (esym
, gfc_current_ns
))
3269 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3270 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3271 " function '%s' is not RECURSIVE",
3272 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3274 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3275 " is not RECURSIVE", esym
->name
, &expr
->where
);
3281 /* Character lengths of use associated functions may contains references to
3282 symbols not referenced from the current program unit otherwise. Make sure
3283 those symbols are marked as referenced. */
3285 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3286 && expr
->value
.function
.esym
->attr
.use_assoc
)
3288 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3291 /* Make sure that the expression has a typespec that works. */
3292 if (expr
->ts
.type
== BT_UNKNOWN
)
3294 if (expr
->symtree
->n
.sym
->result
3295 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3296 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3297 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3304 /************* Subroutine resolution *************/
3307 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3313 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3314 sym
->name
, &c
->loc
);
3315 else if (do_concurrent_flag
)
3316 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3317 "PURE", sym
->name
, &c
->loc
);
3318 else if (gfc_pure (NULL
))
3319 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3322 if (gfc_implicit_pure (NULL
))
3323 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3328 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3332 if (sym
->attr
.generic
)
3334 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3337 c
->resolved_sym
= s
;
3338 pure_subroutine (c
, s
);
3342 /* TODO: Need to search for elemental references in generic interface. */
3345 if (sym
->attr
.intrinsic
)
3346 return gfc_intrinsic_sub_interface (c
, 0);
3353 resolve_generic_s (gfc_code
*c
)
3358 sym
= c
->symtree
->n
.sym
;
3362 m
= resolve_generic_s0 (c
, sym
);
3365 else if (m
== MATCH_ERROR
)
3369 if (sym
->ns
->parent
== NULL
)
3371 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3375 if (!generic_sym (sym
))
3379 /* Last ditch attempt. See if the reference is to an intrinsic
3380 that possesses a matching interface. 14.1.2.4 */
3381 sym
= c
->symtree
->n
.sym
;
3383 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3385 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3386 sym
->name
, &c
->loc
);
3390 m
= gfc_intrinsic_sub_interface (c
, 0);
3394 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3395 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3401 /* Set the name and binding label of the subroutine symbol in the call
3402 expression represented by 'c' to include the type and kind of the
3403 second parameter. This function is for resolving the appropriate
3404 version of c_f_pointer() and c_f_procpointer(). For example, a
3405 call to c_f_pointer() for a default integer pointer could have a
3406 name of c_f_pointer_i4. If no second arg exists, which is an error
3407 for these two functions, it defaults to the generic symbol's name
3408 and binding label. */
3411 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3412 char *name
, const char **binding_label
)
3414 gfc_expr
*arg
= NULL
;
3418 /* The second arg of c_f_pointer and c_f_procpointer determines
3419 the type and kind for the procedure name. */
3420 arg
= c
->ext
.actual
->next
->expr
;
3424 /* Set up the name to have the given symbol's name,
3425 plus the type and kind. */
3426 /* a derived type is marked with the type letter 'u' */
3427 if (arg
->ts
.type
== BT_DERIVED
)
3430 kind
= 0; /* set the kind as 0 for now */
3434 type
= gfc_type_letter (arg
->ts
.type
);
3435 kind
= arg
->ts
.kind
;
3438 if (arg
->ts
.type
== BT_CHARACTER
)
3439 /* Kind info for character strings not needed. */
3442 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3443 /* Set up the binding label as the given symbol's label plus
3444 the type and kind. */
3445 *binding_label
= gfc_get_string ("%s_%c%d", sym
->binding_label
, type
,
3450 /* If the second arg is missing, set the name and label as
3451 was, cause it should at least be found, and the missing
3452 arg error will be caught by compare_parameters(). */
3453 sprintf (name
, "%s", sym
->name
);
3454 *binding_label
= sym
->binding_label
;
3461 /* Resolve a generic version of the iso_c_binding procedure given
3462 (sym) to the specific one based on the type and kind of the
3463 argument(s). Currently, this function resolves c_f_pointer() and
3464 c_f_procpointer based on the type and kind of the second argument
3465 (FPTR). Other iso_c_binding procedures aren't specially handled.
3466 Upon successfully exiting, c->resolved_sym will hold the resolved
3467 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3471 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3473 gfc_symbol
*new_sym
;
3474 /* this is fine, since we know the names won't use the max */
3475 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3476 const char* binding_label
;
3477 /* default to success; will override if find error */
3478 match m
= MATCH_YES
;
3480 /* Make sure the actual arguments are in the necessary order (based on the
3481 formal args) before resolving. */
3482 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3484 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3485 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3487 set_name_and_label (c
, sym
, name
, &binding_label
);
3489 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3491 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3493 /* Make sure we got a third arg if the second arg has non-zero
3494 rank. We must also check that the type and rank are
3495 correct since we short-circuit this check in
3496 gfc_procedure_use() (called above to sort actual args). */
3497 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3499 if(c
->ext
.actual
->next
->next
== NULL
3500 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3503 gfc_error ("Missing SHAPE parameter for call to %s "
3504 "at %L", sym
->name
, &(c
->loc
));
3506 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3508 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3511 gfc_error ("SHAPE parameter for call to %s at %L must "
3512 "be a rank 1 INTEGER array", sym
->name
,
3519 if (m
!= MATCH_ERROR
)
3521 /* the 1 means to add the optional arg to formal list */
3522 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3524 /* for error reporting, say it's declared where the original was */
3525 new_sym
->declared_at
= sym
->declared_at
;
3530 /* no differences for c_loc or c_funloc */
3534 /* set the resolved symbol */
3535 if (m
!= MATCH_ERROR
)
3536 c
->resolved_sym
= new_sym
;
3538 c
->resolved_sym
= sym
;
3544 /* Resolve a subroutine call known to be specific. */
3547 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3551 if(sym
->attr
.is_iso_c
)
3553 m
= gfc_iso_c_sub_interface (c
,sym
);
3557 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3559 if (sym
->attr
.dummy
)
3561 sym
->attr
.proc
= PROC_DUMMY
;
3565 sym
->attr
.proc
= PROC_EXTERNAL
;
3569 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3572 if (sym
->attr
.intrinsic
)
3574 m
= gfc_intrinsic_sub_interface (c
, 1);
3578 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3579 "with an intrinsic", sym
->name
, &c
->loc
);
3587 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3589 c
->resolved_sym
= sym
;
3590 pure_subroutine (c
, sym
);
3597 resolve_specific_s (gfc_code
*c
)
3602 sym
= c
->symtree
->n
.sym
;
3606 m
= resolve_specific_s0 (c
, sym
);
3609 if (m
== MATCH_ERROR
)
3612 if (sym
->ns
->parent
== NULL
)
3615 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3621 sym
= c
->symtree
->n
.sym
;
3622 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3623 sym
->name
, &c
->loc
);
3629 /* Resolve a subroutine call not known to be generic nor specific. */
3632 resolve_unknown_s (gfc_code
*c
)
3636 sym
= c
->symtree
->n
.sym
;
3638 if (sym
->attr
.dummy
)
3640 sym
->attr
.proc
= PROC_DUMMY
;
3644 /* See if we have an intrinsic function reference. */
3646 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3648 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3653 /* The reference is to an external name. */
3656 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3658 c
->resolved_sym
= sym
;
3660 pure_subroutine (c
, sym
);
3666 /* Resolve a subroutine call. Although it was tempting to use the same code
3667 for functions, subroutines and functions are stored differently and this
3668 makes things awkward. */
3671 resolve_call (gfc_code
*c
)
3674 procedure_type ptype
= PROC_INTRINSIC
;
3675 gfc_symbol
*csym
, *sym
;
3676 bool no_formal_args
;
3678 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3680 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3682 gfc_error ("'%s' at %L has a type, which is not consistent with "
3683 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3687 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3690 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3691 sym
= st
? st
->n
.sym
: NULL
;
3692 if (sym
&& csym
!= sym
3693 && sym
->ns
== gfc_current_ns
3694 && sym
->attr
.flavor
== FL_PROCEDURE
3695 && sym
->attr
.contained
)
3698 if (csym
->attr
.generic
)
3699 c
->symtree
->n
.sym
= sym
;
3702 csym
= c
->symtree
->n
.sym
;
3706 /* If this ia a deferred TBP with an abstract interface
3707 (which may of course be referenced), c->expr1 will be set. */
3708 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3710 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3711 csym
->name
, &c
->loc
);
3715 /* Subroutines without the RECURSIVE attribution are not allowed to
3716 * call themselves. */
3717 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3719 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3720 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3721 " subroutine '%s' is not RECURSIVE",
3722 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3724 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3725 " is not RECURSIVE", csym
->name
, &c
->loc
);
3730 /* Switch off assumed size checking and do this again for certain kinds
3731 of procedure, once the procedure itself is resolved. */
3732 need_full_assumed_size
++;
3735 ptype
= csym
->attr
.proc
;
3737 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3738 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3739 no_formal_args
) == FAILURE
)
3742 /* Resume assumed_size checking. */
3743 need_full_assumed_size
--;
3745 /* If external, check for usage. */
3746 if (csym
&& is_external_proc (csym
))
3747 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3750 if (c
->resolved_sym
== NULL
)
3752 c
->resolved_isym
= NULL
;
3753 switch (procedure_kind (csym
))
3756 t
= resolve_generic_s (c
);
3759 case PTYPE_SPECIFIC
:
3760 t
= resolve_specific_s (c
);
3764 t
= resolve_unknown_s (c
);
3768 gfc_internal_error ("resolve_subroutine(): bad function type");
3772 /* Some checks of elemental subroutine actual arguments. */
3773 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3780 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3781 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3782 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3783 if their shapes do not match. If either op1->shape or op2->shape is
3784 NULL, return SUCCESS. */
3787 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3794 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3796 for (i
= 0; i
< op1
->rank
; i
++)
3798 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3800 gfc_error ("Shapes for operands at %L and %L are not conformable",
3801 &op1
->where
, &op2
->where
);
3812 /* Resolve an operator expression node. This can involve replacing the
3813 operation with a user defined function call. */
3816 resolve_operator (gfc_expr
*e
)
3818 gfc_expr
*op1
, *op2
;
3820 bool dual_locus_error
;
3823 /* Resolve all subnodes-- give them types. */
3825 switch (e
->value
.op
.op
)
3828 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3831 /* Fall through... */
3834 case INTRINSIC_UPLUS
:
3835 case INTRINSIC_UMINUS
:
3836 case INTRINSIC_PARENTHESES
:
3837 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3842 /* Typecheck the new node. */
3844 op1
= e
->value
.op
.op1
;
3845 op2
= e
->value
.op
.op2
;
3846 dual_locus_error
= false;
3848 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3849 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3851 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3855 switch (e
->value
.op
.op
)
3857 case INTRINSIC_UPLUS
:
3858 case INTRINSIC_UMINUS
:
3859 if (op1
->ts
.type
== BT_INTEGER
3860 || op1
->ts
.type
== BT_REAL
3861 || op1
->ts
.type
== BT_COMPLEX
)
3867 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3868 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3871 case INTRINSIC_PLUS
:
3872 case INTRINSIC_MINUS
:
3873 case INTRINSIC_TIMES
:
3874 case INTRINSIC_DIVIDE
:
3875 case INTRINSIC_POWER
:
3876 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3878 gfc_type_convert_binary (e
, 1);
3883 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3884 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3885 gfc_typename (&op2
->ts
));
3888 case INTRINSIC_CONCAT
:
3889 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3890 && op1
->ts
.kind
== op2
->ts
.kind
)
3892 e
->ts
.type
= BT_CHARACTER
;
3893 e
->ts
.kind
= op1
->ts
.kind
;
3898 _("Operands of string concatenation operator at %%L are %s/%s"),
3899 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3905 case INTRINSIC_NEQV
:
3906 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3908 e
->ts
.type
= BT_LOGICAL
;
3909 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3910 if (op1
->ts
.kind
< e
->ts
.kind
)
3911 gfc_convert_type (op1
, &e
->ts
, 2);
3912 else if (op2
->ts
.kind
< e
->ts
.kind
)
3913 gfc_convert_type (op2
, &e
->ts
, 2);
3917 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3918 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3919 gfc_typename (&op2
->ts
));
3924 if (op1
->ts
.type
== BT_LOGICAL
)
3926 e
->ts
.type
= BT_LOGICAL
;
3927 e
->ts
.kind
= op1
->ts
.kind
;
3931 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3932 gfc_typename (&op1
->ts
));
3936 case INTRINSIC_GT_OS
:
3938 case INTRINSIC_GE_OS
:
3940 case INTRINSIC_LT_OS
:
3942 case INTRINSIC_LE_OS
:
3943 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3945 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3949 /* Fall through... */
3952 case INTRINSIC_EQ_OS
:
3954 case INTRINSIC_NE_OS
:
3955 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3956 && op1
->ts
.kind
== op2
->ts
.kind
)
3958 e
->ts
.type
= BT_LOGICAL
;
3959 e
->ts
.kind
= gfc_default_logical_kind
;
3963 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3965 gfc_type_convert_binary (e
, 1);
3967 e
->ts
.type
= BT_LOGICAL
;
3968 e
->ts
.kind
= gfc_default_logical_kind
;
3972 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3974 _("Logicals at %%L must be compared with %s instead of %s"),
3975 (e
->value
.op
.op
== INTRINSIC_EQ
3976 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3977 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3980 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3981 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3982 gfc_typename (&op2
->ts
));
3986 case INTRINSIC_USER
:
3987 if (e
->value
.op
.uop
->op
== NULL
)
3988 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3989 else if (op2
== NULL
)
3990 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3991 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3994 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3995 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3996 gfc_typename (&op2
->ts
));
3997 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4002 case INTRINSIC_PARENTHESES
:
4004 if (e
->ts
.type
== BT_CHARACTER
)
4005 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4009 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4012 /* Deal with arrayness of an operand through an operator. */
4016 switch (e
->value
.op
.op
)
4018 case INTRINSIC_PLUS
:
4019 case INTRINSIC_MINUS
:
4020 case INTRINSIC_TIMES
:
4021 case INTRINSIC_DIVIDE
:
4022 case INTRINSIC_POWER
:
4023 case INTRINSIC_CONCAT
:
4027 case INTRINSIC_NEQV
:
4029 case INTRINSIC_EQ_OS
:
4031 case INTRINSIC_NE_OS
:
4033 case INTRINSIC_GT_OS
:
4035 case INTRINSIC_GE_OS
:
4037 case INTRINSIC_LT_OS
:
4039 case INTRINSIC_LE_OS
:
4041 if (op1
->rank
== 0 && op2
->rank
== 0)
4044 if (op1
->rank
== 0 && op2
->rank
!= 0)
4046 e
->rank
= op2
->rank
;
4048 if (e
->shape
== NULL
)
4049 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4052 if (op1
->rank
!= 0 && op2
->rank
== 0)
4054 e
->rank
= op1
->rank
;
4056 if (e
->shape
== NULL
)
4057 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4060 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4062 if (op1
->rank
== op2
->rank
)
4064 e
->rank
= op1
->rank
;
4065 if (e
->shape
== NULL
)
4067 t
= compare_shapes (op1
, op2
);
4071 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4076 /* Allow higher level expressions to work. */
4079 /* Try user-defined operators, and otherwise throw an error. */
4080 dual_locus_error
= true;
4082 _("Inconsistent ranks for operator at %%L and %%L"));
4089 case INTRINSIC_PARENTHESES
:
4091 case INTRINSIC_UPLUS
:
4092 case INTRINSIC_UMINUS
:
4093 /* Simply copy arrayness attribute */
4094 e
->rank
= op1
->rank
;
4096 if (e
->shape
== NULL
)
4097 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4105 /* Attempt to simplify the expression. */
4108 t
= gfc_simplify_expr (e
, 0);
4109 /* Some calls do not succeed in simplification and return FAILURE
4110 even though there is no error; e.g. variable references to
4111 PARAMETER arrays. */
4112 if (!gfc_is_constant_expr (e
))
4120 match m
= gfc_extend_expr (e
);
4123 if (m
== MATCH_ERROR
)
4127 if (dual_locus_error
)
4128 gfc_error (msg
, &op1
->where
, &op2
->where
);
4130 gfc_error (msg
, &e
->where
);
4136 /************** Array resolution subroutines **************/
4139 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4142 /* Compare two integer expressions. */
4145 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4149 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4150 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4153 /* If either of the types isn't INTEGER, we must have
4154 raised an error earlier. */
4156 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4159 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4169 /* Compare an integer expression with an integer. */
4172 compare_bound_int (gfc_expr
*a
, int b
)
4176 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4179 if (a
->ts
.type
!= BT_INTEGER
)
4180 gfc_internal_error ("compare_bound_int(): Bad expression");
4182 i
= mpz_cmp_si (a
->value
.integer
, b
);
4192 /* Compare an integer expression with a mpz_t. */
4195 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4199 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4202 if (a
->ts
.type
!= BT_INTEGER
)
4203 gfc_internal_error ("compare_bound_int(): Bad expression");
4205 i
= mpz_cmp (a
->value
.integer
, b
);
4215 /* Compute the last value of a sequence given by a triplet.
4216 Return 0 if it wasn't able to compute the last value, or if the
4217 sequence if empty, and 1 otherwise. */
4220 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4221 gfc_expr
*stride
, mpz_t last
)
4225 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4226 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4227 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4230 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4231 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4234 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4236 if (compare_bound (start
, end
) == CMP_GT
)
4238 mpz_set (last
, end
->value
.integer
);
4242 if (compare_bound_int (stride
, 0) == CMP_GT
)
4244 /* Stride is positive */
4245 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4250 /* Stride is negative */
4251 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4256 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4257 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4258 mpz_sub (last
, end
->value
.integer
, rem
);
4265 /* Compare a single dimension of an array reference to the array
4269 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4273 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4275 gcc_assert (ar
->stride
[i
] == NULL
);
4276 /* This implies [*] as [*:] and [*:3] are not possible. */
4277 if (ar
->start
[i
] == NULL
)
4279 gcc_assert (ar
->end
[i
] == NULL
);
4284 /* Given start, end and stride values, calculate the minimum and
4285 maximum referenced indexes. */
4287 switch (ar
->dimen_type
[i
])
4290 case DIMEN_THIS_IMAGE
:
4295 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4298 gfc_warning ("Array reference at %L is out of bounds "
4299 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4300 mpz_get_si (ar
->start
[i
]->value
.integer
),
4301 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4303 gfc_warning ("Array reference at %L is out of bounds "
4304 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4305 mpz_get_si (ar
->start
[i
]->value
.integer
),
4306 mpz_get_si (as
->lower
[i
]->value
.integer
),
4310 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4313 gfc_warning ("Array reference at %L is out of bounds "
4314 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4315 mpz_get_si (ar
->start
[i
]->value
.integer
),
4316 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4318 gfc_warning ("Array reference at %L is out of bounds "
4319 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4320 mpz_get_si (ar
->start
[i
]->value
.integer
),
4321 mpz_get_si (as
->upper
[i
]->value
.integer
),
4330 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4331 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4333 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4335 /* Check for zero stride, which is not allowed. */
4336 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4338 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4342 /* if start == len || (stride > 0 && start < len)
4343 || (stride < 0 && start > len),
4344 then the array section contains at least one element. In this
4345 case, there is an out-of-bounds access if
4346 (start < lower || start > upper). */
4347 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4348 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4349 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4350 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4351 && comp_start_end
== CMP_GT
))
4353 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4355 gfc_warning ("Lower array reference at %L is out of bounds "
4356 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4357 mpz_get_si (AR_START
->value
.integer
),
4358 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4361 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4363 gfc_warning ("Lower array reference at %L is out of bounds "
4364 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4365 mpz_get_si (AR_START
->value
.integer
),
4366 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4371 /* If we can compute the highest index of the array section,
4372 then it also has to be between lower and upper. */
4373 mpz_init (last_value
);
4374 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4377 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4379 gfc_warning ("Upper array reference at %L is out of bounds "
4380 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4381 mpz_get_si (last_value
),
4382 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4383 mpz_clear (last_value
);
4386 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4388 gfc_warning ("Upper array reference at %L is out of bounds "
4389 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4390 mpz_get_si (last_value
),
4391 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4392 mpz_clear (last_value
);
4396 mpz_clear (last_value
);
4404 gfc_internal_error ("check_dimension(): Bad array reference");
4411 /* Compare an array reference with an array specification. */
4414 compare_spec_to_ref (gfc_array_ref
*ar
)
4421 /* TODO: Full array sections are only allowed as actual parameters. */
4422 if (as
->type
== AS_ASSUMED_SIZE
4423 && (/*ar->type == AR_FULL
4424 ||*/ (ar
->type
== AR_SECTION
4425 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4427 gfc_error ("Rightmost upper bound of assumed size array section "
4428 "not specified at %L", &ar
->where
);
4432 if (ar
->type
== AR_FULL
)
4435 if (as
->rank
!= ar
->dimen
)
4437 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4438 &ar
->where
, ar
->dimen
, as
->rank
);
4442 /* ar->codimen == 0 is a local array. */
4443 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4445 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4446 &ar
->where
, ar
->codimen
, as
->corank
);
4450 for (i
= 0; i
< as
->rank
; i
++)
4451 if (check_dimension (i
, ar
, as
) == FAILURE
)
4454 /* Local access has no coarray spec. */
4455 if (ar
->codimen
!= 0)
4456 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4458 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4459 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4461 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4462 i
+ 1 - as
->rank
, &ar
->where
);
4465 if (check_dimension (i
, ar
, as
) == FAILURE
)
4473 /* Resolve one part of an array index. */
4476 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4477 int force_index_integer_kind
)
4484 if (gfc_resolve_expr (index
) == FAILURE
)
4487 if (check_scalar
&& index
->rank
!= 0)
4489 gfc_error ("Array index at %L must be scalar", &index
->where
);
4493 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4495 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4496 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4500 if (index
->ts
.type
== BT_REAL
)
4501 if (gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4502 &index
->where
) == FAILURE
)
4505 if ((index
->ts
.kind
!= gfc_index_integer_kind
4506 && force_index_integer_kind
)
4507 || index
->ts
.type
!= BT_INTEGER
)
4510 ts
.type
= BT_INTEGER
;
4511 ts
.kind
= gfc_index_integer_kind
;
4513 gfc_convert_type_warn (index
, &ts
, 2, 0);
4519 /* Resolve one part of an array index. */
4522 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4524 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4527 /* Resolve a dim argument to an intrinsic function. */
4530 gfc_resolve_dim_arg (gfc_expr
*dim
)
4535 if (gfc_resolve_expr (dim
) == FAILURE
)
4540 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4545 if (dim
->ts
.type
!= BT_INTEGER
)
4547 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4551 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4556 ts
.type
= BT_INTEGER
;
4557 ts
.kind
= gfc_index_integer_kind
;
4559 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4565 /* Given an expression that contains array references, update those array
4566 references to point to the right array specifications. While this is
4567 filled in during matching, this information is difficult to save and load
4568 in a module, so we take care of it here.
4570 The idea here is that the original array reference comes from the
4571 base symbol. We traverse the list of reference structures, setting
4572 the stored reference to references. Component references can
4573 provide an additional array specification. */
4576 find_array_spec (gfc_expr
*e
)
4582 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4583 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4585 as
= e
->symtree
->n
.sym
->as
;
4587 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4592 gfc_internal_error ("find_array_spec(): Missing spec");
4599 c
= ref
->u
.c
.component
;
4600 if (c
->attr
.dimension
)
4603 gfc_internal_error ("find_array_spec(): unused as(1)");
4614 gfc_internal_error ("find_array_spec(): unused as(2)");
4618 /* Resolve an array reference. */
4621 resolve_array_ref (gfc_array_ref
*ar
)
4623 int i
, check_scalar
;
4626 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4628 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4630 /* Do not force gfc_index_integer_kind for the start. We can
4631 do fine with any integer kind. This avoids temporary arrays
4632 created for indexing with a vector. */
4633 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4635 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4637 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4642 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4646 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4650 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4651 if (e
->expr_type
== EXPR_VARIABLE
4652 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4653 ar
->start
[i
] = gfc_get_parentheses (e
);
4657 gfc_error ("Array index at %L is an array of rank %d",
4658 &ar
->c_where
[i
], e
->rank
);
4662 /* Fill in the upper bound, which may be lower than the
4663 specified one for something like a(2:10:5), which is
4664 identical to a(2:7:5). Only relevant for strides not equal
4665 to one. Don't try a division by zero. */
4666 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4667 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4668 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4669 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4673 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4675 if (ar
->end
[i
] == NULL
)
4678 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4680 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4682 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4683 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4685 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4696 if (ar
->type
== AR_FULL
)
4698 if (ar
->as
->rank
== 0)
4699 ar
->type
= AR_ELEMENT
;
4701 /* Make sure array is the same as array(:,:), this way
4702 we don't need to special case all the time. */
4703 ar
->dimen
= ar
->as
->rank
;
4704 for (i
= 0; i
< ar
->dimen
; i
++)
4706 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4708 gcc_assert (ar
->start
[i
] == NULL
);
4709 gcc_assert (ar
->end
[i
] == NULL
);
4710 gcc_assert (ar
->stride
[i
] == NULL
);
4714 /* If the reference type is unknown, figure out what kind it is. */
4716 if (ar
->type
== AR_UNKNOWN
)
4718 ar
->type
= AR_ELEMENT
;
4719 for (i
= 0; i
< ar
->dimen
; i
++)
4720 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4721 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4723 ar
->type
= AR_SECTION
;
4728 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4731 if (ar
->as
->corank
&& ar
->codimen
== 0)
4734 ar
->codimen
= ar
->as
->corank
;
4735 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4736 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4744 resolve_substring (gfc_ref
*ref
)
4746 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4748 if (ref
->u
.ss
.start
!= NULL
)
4750 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4753 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4755 gfc_error ("Substring start index at %L must be of type INTEGER",
4756 &ref
->u
.ss
.start
->where
);
4760 if (ref
->u
.ss
.start
->rank
!= 0)
4762 gfc_error ("Substring start index at %L must be scalar",
4763 &ref
->u
.ss
.start
->where
);
4767 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4768 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4769 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4771 gfc_error ("Substring start index at %L is less than one",
4772 &ref
->u
.ss
.start
->where
);
4777 if (ref
->u
.ss
.end
!= NULL
)
4779 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4782 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4784 gfc_error ("Substring end index at %L must be of type INTEGER",
4785 &ref
->u
.ss
.end
->where
);
4789 if (ref
->u
.ss
.end
->rank
!= 0)
4791 gfc_error ("Substring end index at %L must be scalar",
4792 &ref
->u
.ss
.end
->where
);
4796 if (ref
->u
.ss
.length
!= NULL
4797 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4798 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4799 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4801 gfc_error ("Substring end index at %L exceeds the string length",
4802 &ref
->u
.ss
.start
->where
);
4806 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4807 gfc_integer_kinds
[k
].huge
) == CMP_GT
4808 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4809 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4811 gfc_error ("Substring end index at %L is too large",
4812 &ref
->u
.ss
.end
->where
);
4821 /* This function supplies missing substring charlens. */
4824 gfc_resolve_substring_charlen (gfc_expr
*e
)
4827 gfc_expr
*start
, *end
;
4829 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4830 if (char_ref
->type
== REF_SUBSTRING
)
4836 gcc_assert (char_ref
->next
== NULL
);
4840 if (e
->ts
.u
.cl
->length
)
4841 gfc_free_expr (e
->ts
.u
.cl
->length
);
4842 else if (e
->expr_type
== EXPR_VARIABLE
4843 && e
->symtree
->n
.sym
->attr
.dummy
)
4847 e
->ts
.type
= BT_CHARACTER
;
4848 e
->ts
.kind
= gfc_default_character_kind
;
4851 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4853 if (char_ref
->u
.ss
.start
)
4854 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4856 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4858 if (char_ref
->u
.ss
.end
)
4859 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4860 else if (e
->expr_type
== EXPR_VARIABLE
)
4861 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4868 /* Length = (end - start +1). */
4869 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4870 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4871 gfc_get_int_expr (gfc_default_integer_kind
,
4874 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4875 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4877 /* Make sure that the length is simplified. */
4878 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4879 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4883 /* Resolve subtype references. */
4886 resolve_ref (gfc_expr
*expr
)
4888 int current_part_dimension
, n_components
, seen_part_dimension
;
4891 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4892 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4894 find_array_spec (expr
);
4898 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4902 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4910 if (resolve_substring (ref
) == FAILURE
)
4915 /* Check constraints on part references. */
4917 current_part_dimension
= 0;
4918 seen_part_dimension
= 0;
4921 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4926 switch (ref
->u
.ar
.type
)
4929 /* Coarray scalar. */
4930 if (ref
->u
.ar
.as
->rank
== 0)
4932 current_part_dimension
= 0;
4937 current_part_dimension
= 1;
4941 current_part_dimension
= 0;
4945 gfc_internal_error ("resolve_ref(): Bad array reference");
4951 if (current_part_dimension
|| seen_part_dimension
)
4954 if (ref
->u
.c
.component
->attr
.pointer
4955 || ref
->u
.c
.component
->attr
.proc_pointer
4956 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4957 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
4959 gfc_error ("Component to the right of a part reference "
4960 "with nonzero rank must not have the POINTER "
4961 "attribute at %L", &expr
->where
);
4964 else if (ref
->u
.c
.component
->attr
.allocatable
4965 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
4966 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
4969 gfc_error ("Component to the right of a part reference "
4970 "with nonzero rank must not have the ALLOCATABLE "
4971 "attribute at %L", &expr
->where
);
4983 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4984 || ref
->next
== NULL
)
4985 && current_part_dimension
4986 && seen_part_dimension
)
4988 gfc_error ("Two or more part references with nonzero rank must "
4989 "not be specified at %L", &expr
->where
);
4993 if (ref
->type
== REF_COMPONENT
)
4995 if (current_part_dimension
)
4996 seen_part_dimension
= 1;
4998 /* reset to make sure */
4999 current_part_dimension
= 0;
5007 /* Given an expression, determine its shape. This is easier than it sounds.
5008 Leaves the shape array NULL if it is not possible to determine the shape. */
5011 expression_shape (gfc_expr
*e
)
5013 mpz_t array
[GFC_MAX_DIMENSIONS
];
5016 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5019 for (i
= 0; i
< e
->rank
; i
++)
5020 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
5023 e
->shape
= gfc_get_shape (e
->rank
);
5025 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5030 for (i
--; i
>= 0; i
--)
5031 mpz_clear (array
[i
]);
5035 /* Given a variable expression node, compute the rank of the expression by
5036 examining the base symbol and any reference structures it may have. */
5039 expression_rank (gfc_expr
*e
)
5044 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5045 could lead to serious confusion... */
5046 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5050 if (e
->expr_type
== EXPR_ARRAY
)
5052 /* Constructors can have a rank different from one via RESHAPE(). */
5054 if (e
->symtree
== NULL
)
5060 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5061 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5067 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5069 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5070 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5071 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5073 if (ref
->type
!= REF_ARRAY
)
5076 if (ref
->u
.ar
.type
== AR_FULL
)
5078 rank
= ref
->u
.ar
.as
->rank
;
5082 if (ref
->u
.ar
.type
== AR_SECTION
)
5084 /* Figure out the rank of the section. */
5086 gfc_internal_error ("expression_rank(): Two array specs");
5088 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5089 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5090 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5100 expression_shape (e
);
5104 /* Resolve a variable expression. */
5107 resolve_variable (gfc_expr
*e
)
5114 if (e
->symtree
== NULL
)
5116 sym
= e
->symtree
->n
.sym
;
5118 /* TS 29113, 407b. */
5119 if (e
->ts
.type
== BT_ASSUMED
)
5123 gfc_error ("Assumed-type variable %s at %L may only be used "
5124 "as actual argument", sym
->name
, &e
->where
);
5127 else if (inquiry_argument
&& !first_actual_arg
)
5129 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5130 for all inquiry functions in resolve_function; the reason is
5131 that the function-name resolution happens too late in that
5133 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5134 "an inquiry function shall be the first argument",
5135 sym
->name
, &e
->where
);
5140 /* TS 29113, C535b. */
5141 if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5142 && CLASS_DATA (sym
)->as
5143 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5144 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5145 && sym
->as
->type
== AS_ASSUMED_RANK
))
5149 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5150 "actual argument", sym
->name
, &e
->where
);
5153 else if (inquiry_argument
&& !first_actual_arg
)
5155 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5156 for all inquiry functions in resolve_function; the reason is
5157 that the function-name resolution happens too late in that
5159 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5160 "to an inquiry function shall be the first argument",
5161 sym
->name
, &e
->where
);
5166 /* TS 29113, 407b. */
5167 if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5168 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5169 && e
->ref
->next
== NULL
))
5171 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5172 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5176 /* TS 29113, C535b. */
5177 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5178 && CLASS_DATA (sym
)->as
5179 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5180 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5181 && sym
->as
->type
== AS_ASSUMED_RANK
))
5183 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5184 && e
->ref
->next
== NULL
))
5186 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5187 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5192 /* If this is an associate-name, it may be parsed with an array reference
5193 in error even though the target is scalar. Fail directly in this case.
5194 TODO Understand why class scalar expressions must be excluded. */
5195 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5197 if (sym
->ts
.type
== BT_CLASS
)
5198 gfc_fix_class_refs (e
);
5199 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5203 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5204 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5206 /* On the other hand, the parser may not have known this is an array;
5207 in this case, we have to add a FULL reference. */
5208 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5210 e
->ref
= gfc_get_ref ();
5211 e
->ref
->type
= REF_ARRAY
;
5212 e
->ref
->u
.ar
.type
= AR_FULL
;
5213 e
->ref
->u
.ar
.dimen
= 0;
5216 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5219 if (sym
->attr
.flavor
== FL_PROCEDURE
5220 && (!sym
->attr
.function
5221 || (sym
->attr
.function
&& sym
->result
5222 && sym
->result
->attr
.proc_pointer
5223 && !sym
->result
->attr
.function
)))
5225 e
->ts
.type
= BT_PROCEDURE
;
5226 goto resolve_procedure
;
5229 if (sym
->ts
.type
!= BT_UNKNOWN
)
5230 gfc_variable_attr (e
, &e
->ts
);
5233 /* Must be a simple variable reference. */
5234 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5239 if (check_assumed_size_reference (sym
, e
))
5242 /* If a PRIVATE variable is used in the specification expression of the
5243 result variable, it might be accessed from outside the module and can
5244 thus not be TREE_PUBLIC() = 0.
5245 TODO: sym->attr.public_used only has to be set for the result variable's
5246 type-parameter expression and not for dummies or automatic variables.
5247 Additionally, it only has to be set if the function is either PUBLIC or
5248 used in a generic interface or TBP; unfortunately,
5249 proc_name->attr.public_used can get set at a later stage. */
5250 if (specification_expr
&& sym
->attr
.access
== ACCESS_PRIVATE
5251 && !sym
->attr
.function
&& !sym
->attr
.use_assoc
5252 && gfc_current_ns
->proc_name
&& gfc_current_ns
->proc_name
->attr
.function
)
5253 sym
->attr
.public_used
= 1;
5255 /* Deal with forward references to entries during resolve_code, to
5256 satisfy, at least partially, 12.5.2.5. */
5257 if (gfc_current_ns
->entries
5258 && current_entry_id
== sym
->entry_id
5261 && cs_base
->current
->op
!= EXEC_ENTRY
)
5263 gfc_entry_list
*entry
;
5264 gfc_formal_arglist
*formal
;
5268 /* If the symbol is a dummy... */
5269 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5271 entry
= gfc_current_ns
->entries
;
5274 /* ...test if the symbol is a parameter of previous entries. */
5275 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5276 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5278 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5282 /* If it has not been seen as a dummy, this is an error. */
5285 if (specification_expr
)
5286 gfc_error ("Variable '%s', used in a specification expression"
5287 ", is referenced at %L before the ENTRY statement "
5288 "in which it is a parameter",
5289 sym
->name
, &cs_base
->current
->loc
);
5291 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5292 "statement in which it is a parameter",
5293 sym
->name
, &cs_base
->current
->loc
);
5298 /* Now do the same check on the specification expressions. */
5299 specification_expr
= 1;
5300 if (sym
->ts
.type
== BT_CHARACTER
5301 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5305 for (n
= 0; n
< sym
->as
->rank
; n
++)
5307 specification_expr
= 1;
5308 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5310 specification_expr
= 1;
5311 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5314 specification_expr
= 0;
5317 /* Update the symbol's entry level. */
5318 sym
->entry_id
= current_entry_id
+ 1;
5321 /* If a symbol has been host_associated mark it. This is used latter,
5322 to identify if aliasing is possible via host association. */
5323 if (sym
->attr
.flavor
== FL_VARIABLE
5324 && gfc_current_ns
->parent
5325 && (gfc_current_ns
->parent
== sym
->ns
5326 || (gfc_current_ns
->parent
->parent
5327 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5328 sym
->attr
.host_assoc
= 1;
5331 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5334 /* F2008, C617 and C1229. */
5335 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5336 && gfc_is_coindexed (e
))
5338 gfc_ref
*ref
, *ref2
= NULL
;
5340 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5342 if (ref
->type
== REF_COMPONENT
)
5344 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5348 for ( ; ref
; ref
= ref
->next
)
5349 if (ref
->type
== REF_COMPONENT
)
5352 /* Expression itself is not coindexed object. */
5353 if (ref
&& e
->ts
.type
== BT_CLASS
)
5355 gfc_error ("Polymorphic subobject of coindexed object at %L",
5360 /* Expression itself is coindexed object. */
5364 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5365 for ( ; c
; c
= c
->next
)
5366 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5368 gfc_error ("Coindexed object with polymorphic allocatable "
5369 "subcomponent at %L", &e
->where
);
5380 /* Checks to see that the correct symbol has been host associated.
5381 The only situation where this arises is that in which a twice
5382 contained function is parsed after the host association is made.
5383 Therefore, on detecting this, change the symbol in the expression
5384 and convert the array reference into an actual arglist if the old
5385 symbol is a variable. */
5387 check_host_association (gfc_expr
*e
)
5389 gfc_symbol
*sym
, *old_sym
;
5393 gfc_actual_arglist
*arg
, *tail
= NULL
;
5394 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5396 /* If the expression is the result of substitution in
5397 interface.c(gfc_extend_expr) because there is no way in
5398 which the host association can be wrong. */
5399 if (e
->symtree
== NULL
5400 || e
->symtree
->n
.sym
== NULL
5401 || e
->user_operator
)
5404 old_sym
= e
->symtree
->n
.sym
;
5406 if (gfc_current_ns
->parent
5407 && old_sym
->ns
!= gfc_current_ns
)
5409 /* Use the 'USE' name so that renamed module symbols are
5410 correctly handled. */
5411 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5413 if (sym
&& old_sym
!= sym
5414 && sym
->ts
.type
== old_sym
->ts
.type
5415 && sym
->attr
.flavor
== FL_PROCEDURE
5416 && sym
->attr
.contained
)
5418 /* Clear the shape, since it might not be valid. */
5419 gfc_free_shape (&e
->shape
, e
->rank
);
5421 /* Give the expression the right symtree! */
5422 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5423 gcc_assert (st
!= NULL
);
5425 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5426 || e
->expr_type
== EXPR_FUNCTION
)
5428 /* Original was function so point to the new symbol, since
5429 the actual argument list is already attached to the
5431 e
->value
.function
.esym
= NULL
;
5436 /* Original was variable so convert array references into
5437 an actual arglist. This does not need any checking now
5438 since resolve_function will take care of it. */
5439 e
->value
.function
.actual
= NULL
;
5440 e
->expr_type
= EXPR_FUNCTION
;
5443 /* Ambiguity will not arise if the array reference is not
5444 the last reference. */
5445 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5446 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5449 gcc_assert (ref
->type
== REF_ARRAY
);
5451 /* Grab the start expressions from the array ref and
5452 copy them into actual arguments. */
5453 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5455 arg
= gfc_get_actual_arglist ();
5456 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5457 if (e
->value
.function
.actual
== NULL
)
5458 tail
= e
->value
.function
.actual
= arg
;
5466 /* Dump the reference list and set the rank. */
5467 gfc_free_ref_list (e
->ref
);
5469 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5472 gfc_resolve_expr (e
);
5476 /* This might have changed! */
5477 return e
->expr_type
== EXPR_FUNCTION
;
5482 gfc_resolve_character_operator (gfc_expr
*e
)
5484 gfc_expr
*op1
= e
->value
.op
.op1
;
5485 gfc_expr
*op2
= e
->value
.op
.op2
;
5486 gfc_expr
*e1
= NULL
;
5487 gfc_expr
*e2
= NULL
;
5489 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5491 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5492 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5493 else if (op1
->expr_type
== EXPR_CONSTANT
)
5494 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5495 op1
->value
.character
.length
);
5497 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5498 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5499 else if (op2
->expr_type
== EXPR_CONSTANT
)
5500 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5501 op2
->value
.character
.length
);
5503 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5508 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5509 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5510 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5511 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5512 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5518 /* Ensure that an character expression has a charlen and, if possible, a
5519 length expression. */
5522 fixup_charlen (gfc_expr
*e
)
5524 /* The cases fall through so that changes in expression type and the need
5525 for multiple fixes are picked up. In all circumstances, a charlen should
5526 be available for the middle end to hang a backend_decl on. */
5527 switch (e
->expr_type
)
5530 gfc_resolve_character_operator (e
);
5533 if (e
->expr_type
== EXPR_ARRAY
)
5534 gfc_resolve_character_array_constructor (e
);
5536 case EXPR_SUBSTRING
:
5537 if (!e
->ts
.u
.cl
&& e
->ref
)
5538 gfc_resolve_substring_charlen (e
);
5542 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5549 /* Update an actual argument to include the passed-object for type-bound
5550 procedures at the right position. */
5552 static gfc_actual_arglist
*
5553 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5556 gcc_assert (argpos
> 0);
5560 gfc_actual_arglist
* result
;
5562 result
= gfc_get_actual_arglist ();
5566 result
->name
= name
;
5572 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5574 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5579 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5582 extract_compcall_passed_object (gfc_expr
* e
)
5586 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5588 if (e
->value
.compcall
.base_object
)
5589 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5592 po
= gfc_get_expr ();
5593 po
->expr_type
= EXPR_VARIABLE
;
5594 po
->symtree
= e
->symtree
;
5595 po
->ref
= gfc_copy_ref (e
->ref
);
5596 po
->where
= e
->where
;
5599 if (gfc_resolve_expr (po
) == FAILURE
)
5606 /* Update the arglist of an EXPR_COMPCALL expression to include the
5610 update_compcall_arglist (gfc_expr
* e
)
5613 gfc_typebound_proc
* tbp
;
5615 tbp
= e
->value
.compcall
.tbp
;
5620 po
= extract_compcall_passed_object (e
);
5624 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5630 gcc_assert (tbp
->pass_arg_num
> 0);
5631 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5639 /* Extract the passed object from a PPC call (a copy of it). */
5642 extract_ppc_passed_object (gfc_expr
*e
)
5647 po
= gfc_get_expr ();
5648 po
->expr_type
= EXPR_VARIABLE
;
5649 po
->symtree
= e
->symtree
;
5650 po
->ref
= gfc_copy_ref (e
->ref
);
5651 po
->where
= e
->where
;
5653 /* Remove PPC reference. */
5655 while ((*ref
)->next
)
5656 ref
= &(*ref
)->next
;
5657 gfc_free_ref_list (*ref
);
5660 if (gfc_resolve_expr (po
) == FAILURE
)
5667 /* Update the actual arglist of a procedure pointer component to include the
5671 update_ppc_arglist (gfc_expr
* e
)
5675 gfc_typebound_proc
* tb
;
5677 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5684 else if (tb
->nopass
)
5687 po
= extract_ppc_passed_object (e
);
5694 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5699 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5701 gfc_error ("Base object for procedure-pointer component call at %L is of"
5702 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5706 gcc_assert (tb
->pass_arg_num
> 0);
5707 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5715 /* Check that the object a TBP is called on is valid, i.e. it must not be
5716 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5719 check_typebound_baseobject (gfc_expr
* e
)
5722 gfc_try return_value
= FAILURE
;
5724 base
= extract_compcall_passed_object (e
);
5728 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5731 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5733 gfc_error ("Base object for type-bound procedure call at %L is of"
5734 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5738 /* F08:C1230. If the procedure called is NOPASS,
5739 the base object must be scalar. */
5740 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5742 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5743 " be scalar", &e
->where
);
5747 return_value
= SUCCESS
;
5750 gfc_free_expr (base
);
5751 return return_value
;
5755 /* Resolve a call to a type-bound procedure, either function or subroutine,
5756 statically from the data in an EXPR_COMPCALL expression. The adapted
5757 arglist and the target-procedure symtree are returned. */
5760 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5761 gfc_actual_arglist
** actual
)
5763 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5764 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5766 /* Update the actual arglist for PASS. */
5767 if (update_compcall_arglist (e
) == FAILURE
)
5770 *actual
= e
->value
.compcall
.actual
;
5771 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5773 gfc_free_ref_list (e
->ref
);
5775 e
->value
.compcall
.actual
= NULL
;
5777 /* If we find a deferred typebound procedure, check for derived types
5778 that an overriding typebound procedure has not been missed. */
5779 if (e
->value
.compcall
.name
5780 && !e
->value
.compcall
.tbp
->non_overridable
5781 && e
->value
.compcall
.base_object
5782 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5785 gfc_symbol
*derived
;
5787 /* Use the derived type of the base_object. */
5788 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5791 /* If necessary, go through the inheritance chain. */
5792 while (!st
&& derived
)
5794 /* Look for the typebound procedure 'name'. */
5795 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5796 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5797 e
->value
.compcall
.name
);
5799 derived
= gfc_get_derived_super_type (derived
);
5802 /* Now find the specific name in the derived type namespace. */
5803 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5804 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5805 derived
->ns
, 1, &st
);
5813 /* Get the ultimate declared type from an expression. In addition,
5814 return the last class/derived type reference and the copy of the
5815 reference list. If check_types is set true, derived types are
5816 identified as well as class references. */
5818 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5819 gfc_expr
*e
, bool check_types
)
5821 gfc_symbol
*declared
;
5828 *new_ref
= gfc_copy_ref (e
->ref
);
5830 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5832 if (ref
->type
!= REF_COMPONENT
)
5835 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5836 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5837 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5839 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5845 if (declared
== NULL
)
5846 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5852 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5853 which of the specific bindings (if any) matches the arglist and transform
5854 the expression into a call of that binding. */
5857 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5859 gfc_typebound_proc
* genproc
;
5860 const char* genname
;
5862 gfc_symbol
*derived
;
5864 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5865 genname
= e
->value
.compcall
.name
;
5866 genproc
= e
->value
.compcall
.tbp
;
5868 if (!genproc
->is_generic
)
5871 /* Try the bindings on this type and in the inheritance hierarchy. */
5872 for (; genproc
; genproc
= genproc
->overridden
)
5876 gcc_assert (genproc
->is_generic
);
5877 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5880 gfc_actual_arglist
* args
;
5883 gcc_assert (g
->specific
);
5885 if (g
->specific
->error
)
5888 target
= g
->specific
->u
.specific
->n
.sym
;
5890 /* Get the right arglist by handling PASS/NOPASS. */
5891 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5892 if (!g
->specific
->nopass
)
5895 po
= extract_compcall_passed_object (e
);
5899 gcc_assert (g
->specific
->pass_arg_num
> 0);
5900 gcc_assert (!g
->specific
->error
);
5901 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5902 g
->specific
->pass_arg
);
5904 resolve_actual_arglist (args
, target
->attr
.proc
,
5905 is_external_proc (target
) && !target
->formal
);
5907 /* Check if this arglist matches the formal. */
5908 matches
= gfc_arglist_matches_symbol (&args
, target
);
5910 /* Clean up and break out of the loop if we've found it. */
5911 gfc_free_actual_arglist (args
);
5914 e
->value
.compcall
.tbp
= g
->specific
;
5915 genname
= g
->specific_st
->name
;
5916 /* Pass along the name for CLASS methods, where the vtab
5917 procedure pointer component has to be referenced. */
5925 /* Nothing matching found! */
5926 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5927 " '%s' at %L", genname
, &e
->where
);
5931 /* Make sure that we have the right specific instance for the name. */
5932 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
5934 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
5936 e
->value
.compcall
.tbp
= st
->n
.tb
;
5942 /* Resolve a call to a type-bound subroutine. */
5945 resolve_typebound_call (gfc_code
* c
, const char **name
)
5947 gfc_actual_arglist
* newactual
;
5948 gfc_symtree
* target
;
5950 /* Check that's really a SUBROUTINE. */
5951 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5953 gfc_error ("'%s' at %L should be a SUBROUTINE",
5954 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5958 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5961 /* Pass along the name for CLASS methods, where the vtab
5962 procedure pointer component has to be referenced. */
5964 *name
= c
->expr1
->value
.compcall
.name
;
5966 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5969 /* Transform into an ordinary EXEC_CALL for now. */
5971 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5974 c
->ext
.actual
= newactual
;
5975 c
->symtree
= target
;
5976 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5978 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5980 gfc_free_expr (c
->expr1
);
5981 c
->expr1
= gfc_get_expr ();
5982 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5983 c
->expr1
->symtree
= target
;
5984 c
->expr1
->where
= c
->loc
;
5986 return resolve_call (c
);
5990 /* Resolve a component-call expression. */
5992 resolve_compcall (gfc_expr
* e
, const char **name
)
5994 gfc_actual_arglist
* newactual
;
5995 gfc_symtree
* target
;
5997 /* Check that's really a FUNCTION. */
5998 if (!e
->value
.compcall
.tbp
->function
)
6000 gfc_error ("'%s' at %L should be a FUNCTION",
6001 e
->value
.compcall
.name
, &e
->where
);
6005 /* These must not be assign-calls! */
6006 gcc_assert (!e
->value
.compcall
.assign
);
6008 if (check_typebound_baseobject (e
) == FAILURE
)
6011 /* Pass along the name for CLASS methods, where the vtab
6012 procedure pointer component has to be referenced. */
6014 *name
= e
->value
.compcall
.name
;
6016 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
6018 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6020 /* Take the rank from the function's symbol. */
6021 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6022 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6024 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6025 arglist to the TBP's binding target. */
6027 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
6030 e
->value
.function
.actual
= newactual
;
6031 e
->value
.function
.name
= NULL
;
6032 e
->value
.function
.esym
= target
->n
.sym
;
6033 e
->value
.function
.isym
= NULL
;
6034 e
->symtree
= target
;
6035 e
->ts
= target
->n
.sym
->ts
;
6036 e
->expr_type
= EXPR_FUNCTION
;
6038 /* Resolution is not necessary if this is a class subroutine; this
6039 function only has to identify the specific proc. Resolution of
6040 the call will be done next in resolve_typebound_call. */
6041 return gfc_resolve_expr (e
);
6046 /* Resolve a typebound function, or 'method'. First separate all
6047 the non-CLASS references by calling resolve_compcall directly. */
6050 resolve_typebound_function (gfc_expr
* e
)
6052 gfc_symbol
*declared
;
6064 /* Deal with typebound operators for CLASS objects. */
6065 expr
= e
->value
.compcall
.base_object
;
6066 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6067 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6069 /* If the base_object is not a variable, the corresponding actual
6070 argument expression must be stored in e->base_expression so
6071 that the corresponding tree temporary can be used as the base
6072 object in gfc_conv_procedure_call. */
6073 if (expr
->expr_type
!= EXPR_VARIABLE
)
6075 gfc_actual_arglist
*args
;
6077 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6079 if (expr
== args
->expr
)
6084 /* Since the typebound operators are generic, we have to ensure
6085 that any delays in resolution are corrected and that the vtab
6088 declared
= ts
.u
.derived
;
6089 c
= gfc_find_component (declared
, "_vptr", true, true);
6090 if (c
->ts
.u
.derived
== NULL
)
6091 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6093 if (resolve_compcall (e
, &name
) == FAILURE
)
6096 /* Use the generic name if it is there. */
6097 name
= name
? name
: e
->value
.function
.esym
->name
;
6098 e
->symtree
= expr
->symtree
;
6099 e
->ref
= gfc_copy_ref (expr
->ref
);
6100 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6102 /* Trim away the extraneous references that emerge from nested
6103 use of interface.c (extend_expr). */
6104 if (class_ref
&& class_ref
->next
)
6106 gfc_free_ref_list (class_ref
->next
);
6107 class_ref
->next
= NULL
;
6109 else if (e
->ref
&& !class_ref
)
6111 gfc_free_ref_list (e
->ref
);
6115 gfc_add_vptr_component (e
);
6116 gfc_add_component_ref (e
, name
);
6117 e
->value
.function
.esym
= NULL
;
6118 if (expr
->expr_type
!= EXPR_VARIABLE
)
6119 e
->base_expr
= expr
;
6124 return resolve_compcall (e
, NULL
);
6126 if (resolve_ref (e
) == FAILURE
)
6129 /* Get the CLASS declared type. */
6130 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6132 /* Weed out cases of the ultimate component being a derived type. */
6133 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6134 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6136 gfc_free_ref_list (new_ref
);
6137 return resolve_compcall (e
, NULL
);
6140 c
= gfc_find_component (declared
, "_data", true, true);
6141 declared
= c
->ts
.u
.derived
;
6143 /* Treat the call as if it is a typebound procedure, in order to roll
6144 out the correct name for the specific function. */
6145 if (resolve_compcall (e
, &name
) == FAILURE
)
6151 /* Convert the expression to a procedure pointer component call. */
6152 e
->value
.function
.esym
= NULL
;
6158 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6159 gfc_add_vptr_component (e
);
6160 gfc_add_component_ref (e
, name
);
6162 /* Recover the typespec for the expression. This is really only
6163 necessary for generic procedures, where the additional call
6164 to gfc_add_component_ref seems to throw the collection of the
6165 correct typespec. */
6172 /* Resolve a typebound subroutine, or 'method'. First separate all
6173 the non-CLASS references by calling resolve_typebound_call
6177 resolve_typebound_subroutine (gfc_code
*code
)
6179 gfc_symbol
*declared
;
6189 st
= code
->expr1
->symtree
;
6191 /* Deal with typebound operators for CLASS objects. */
6192 expr
= code
->expr1
->value
.compcall
.base_object
;
6193 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6194 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6196 /* If the base_object is not a variable, the corresponding actual
6197 argument expression must be stored in e->base_expression so
6198 that the corresponding tree temporary can be used as the base
6199 object in gfc_conv_procedure_call. */
6200 if (expr
->expr_type
!= EXPR_VARIABLE
)
6202 gfc_actual_arglist
*args
;
6204 args
= code
->expr1
->value
.function
.actual
;
6205 for (; args
; args
= args
->next
)
6206 if (expr
== args
->expr
)
6210 /* Since the typebound operators are generic, we have to ensure
6211 that any delays in resolution are corrected and that the vtab
6213 declared
= expr
->ts
.u
.derived
;
6214 c
= gfc_find_component (declared
, "_vptr", true, true);
6215 if (c
->ts
.u
.derived
== NULL
)
6216 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6218 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6221 /* Use the generic name if it is there. */
6222 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6223 code
->expr1
->symtree
= expr
->symtree
;
6224 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6226 /* Trim away the extraneous references that emerge from nested
6227 use of interface.c (extend_expr). */
6228 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6229 if (class_ref
&& class_ref
->next
)
6231 gfc_free_ref_list (class_ref
->next
);
6232 class_ref
->next
= NULL
;
6234 else if (code
->expr1
->ref
&& !class_ref
)
6236 gfc_free_ref_list (code
->expr1
->ref
);
6237 code
->expr1
->ref
= NULL
;
6240 /* Now use the procedure in the vtable. */
6241 gfc_add_vptr_component (code
->expr1
);
6242 gfc_add_component_ref (code
->expr1
, name
);
6243 code
->expr1
->value
.function
.esym
= NULL
;
6244 if (expr
->expr_type
!= EXPR_VARIABLE
)
6245 code
->expr1
->base_expr
= expr
;
6250 return resolve_typebound_call (code
, NULL
);
6252 if (resolve_ref (code
->expr1
) == FAILURE
)
6255 /* Get the CLASS declared type. */
6256 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6258 /* Weed out cases of the ultimate component being a derived type. */
6259 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6260 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6262 gfc_free_ref_list (new_ref
);
6263 return resolve_typebound_call (code
, NULL
);
6266 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6268 ts
= code
->expr1
->ts
;
6272 /* Convert the expression to a procedure pointer component call. */
6273 code
->expr1
->value
.function
.esym
= NULL
;
6274 code
->expr1
->symtree
= st
;
6277 code
->expr1
->ref
= new_ref
;
6279 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6280 gfc_add_vptr_component (code
->expr1
);
6281 gfc_add_component_ref (code
->expr1
, name
);
6283 /* Recover the typespec for the expression. This is really only
6284 necessary for generic procedures, where the additional call
6285 to gfc_add_component_ref seems to throw the collection of the
6286 correct typespec. */
6287 code
->expr1
->ts
= ts
;
6294 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6297 resolve_ppc_call (gfc_code
* c
)
6299 gfc_component
*comp
;
6302 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
6305 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6306 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6308 if (!comp
->attr
.subroutine
)
6309 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6311 if (resolve_ref (c
->expr1
) == FAILURE
)
6314 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6317 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6319 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6320 comp
->formal
== NULL
) == FAILURE
)
6323 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6329 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6332 resolve_expr_ppc (gfc_expr
* e
)
6334 gfc_component
*comp
;
6337 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6340 /* Convert to EXPR_FUNCTION. */
6341 e
->expr_type
= EXPR_FUNCTION
;
6342 e
->value
.function
.isym
= NULL
;
6343 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6345 if (comp
->as
!= NULL
)
6346 e
->rank
= comp
->as
->rank
;
6348 if (!comp
->attr
.function
)
6349 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6351 if (resolve_ref (e
) == FAILURE
)
6354 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6355 comp
->formal
== NULL
) == FAILURE
)
6358 if (update_ppc_arglist (e
) == FAILURE
)
6361 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6368 gfc_is_expandable_expr (gfc_expr
*e
)
6370 gfc_constructor
*con
;
6372 if (e
->expr_type
== EXPR_ARRAY
)
6374 /* Traverse the constructor looking for variables that are flavor
6375 parameter. Parameters must be expanded since they are fully used at
6377 con
= gfc_constructor_first (e
->value
.constructor
);
6378 for (; con
; con
= gfc_constructor_next (con
))
6380 if (con
->expr
->expr_type
== EXPR_VARIABLE
6381 && con
->expr
->symtree
6382 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6383 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6385 if (con
->expr
->expr_type
== EXPR_ARRAY
6386 && gfc_is_expandable_expr (con
->expr
))
6394 /* Resolve an expression. That is, make sure that types of operands agree
6395 with their operators, intrinsic operators are converted to function calls
6396 for overloaded types and unresolved function references are resolved. */
6399 gfc_resolve_expr (gfc_expr
*e
)
6402 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6407 /* inquiry_argument only applies to variables. */
6408 inquiry_save
= inquiry_argument
;
6409 actual_arg_save
= actual_arg
;
6410 first_actual_arg_save
= first_actual_arg
;
6412 if (e
->expr_type
!= EXPR_VARIABLE
)
6414 inquiry_argument
= false;
6416 first_actual_arg
= false;
6419 switch (e
->expr_type
)
6422 t
= resolve_operator (e
);
6428 if (check_host_association (e
))
6429 t
= resolve_function (e
);
6432 t
= resolve_variable (e
);
6434 expression_rank (e
);
6437 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6438 && e
->ref
->type
!= REF_SUBSTRING
)
6439 gfc_resolve_substring_charlen (e
);
6444 t
= resolve_typebound_function (e
);
6447 case EXPR_SUBSTRING
:
6448 t
= resolve_ref (e
);
6457 t
= resolve_expr_ppc (e
);
6462 if (resolve_ref (e
) == FAILURE
)
6465 t
= gfc_resolve_array_constructor (e
);
6466 /* Also try to expand a constructor. */
6469 expression_rank (e
);
6470 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6471 gfc_expand_constructor (e
, false);
6474 /* This provides the opportunity for the length of constructors with
6475 character valued function elements to propagate the string length
6476 to the expression. */
6477 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6479 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6480 here rather then add a duplicate test for it above. */
6481 gfc_expand_constructor (e
, false);
6482 t
= gfc_resolve_character_array_constructor (e
);
6487 case EXPR_STRUCTURE
:
6488 t
= resolve_ref (e
);
6492 t
= resolve_structure_cons (e
, 0);
6496 t
= gfc_simplify_expr (e
, 0);
6500 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6503 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6506 inquiry_argument
= inquiry_save
;
6507 actual_arg
= actual_arg_save
;
6508 first_actual_arg
= first_actual_arg_save
;
6514 /* Resolve an expression from an iterator. They must be scalar and have
6515 INTEGER or (optionally) REAL type. */
6518 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6519 const char *name_msgid
)
6521 if (gfc_resolve_expr (expr
) == FAILURE
)
6524 if (expr
->rank
!= 0)
6526 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6530 if (expr
->ts
.type
!= BT_INTEGER
)
6532 if (expr
->ts
.type
== BT_REAL
)
6535 return gfc_notify_std (GFC_STD_F95_DEL
,
6536 "%s at %L must be integer",
6537 _(name_msgid
), &expr
->where
);
6540 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6547 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6555 /* Resolve the expressions in an iterator structure. If REAL_OK is
6556 false allow only INTEGER type iterators, otherwise allow REAL types. */
6559 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6561 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6565 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6569 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6570 "Start expression in DO loop") == FAILURE
)
6573 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6574 "End expression in DO loop") == FAILURE
)
6577 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6578 "Step expression in DO loop") == FAILURE
)
6581 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6583 if ((iter
->step
->ts
.type
== BT_INTEGER
6584 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6585 || (iter
->step
->ts
.type
== BT_REAL
6586 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6588 gfc_error ("Step expression in DO loop at %L cannot be zero",
6589 &iter
->step
->where
);
6594 /* Convert start, end, and step to the same type as var. */
6595 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6596 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6597 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6599 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6600 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6601 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6603 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6604 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6605 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6607 if (iter
->start
->expr_type
== EXPR_CONSTANT
6608 && iter
->end
->expr_type
== EXPR_CONSTANT
6609 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6612 if (iter
->start
->ts
.type
== BT_INTEGER
)
6614 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6615 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6619 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6620 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6622 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6623 gfc_warning ("DO loop at %L will be executed zero times",
6624 &iter
->step
->where
);
6631 /* Traversal function for find_forall_index. f == 2 signals that
6632 that variable itself is not to be checked - only the references. */
6635 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6637 if (expr
->expr_type
!= EXPR_VARIABLE
)
6640 /* A scalar assignment */
6641 if (!expr
->ref
|| *f
== 1)
6643 if (expr
->symtree
->n
.sym
== sym
)
6655 /* Check whether the FORALL index appears in the expression or not.
6656 Returns SUCCESS if SYM is found in EXPR. */
6659 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6661 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6668 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6669 to be a scalar INTEGER variable. The subscripts and stride are scalar
6670 INTEGERs, and if stride is a constant it must be nonzero.
6671 Furthermore "A subscript or stride in a forall-triplet-spec shall
6672 not contain a reference to any index-name in the
6673 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6676 resolve_forall_iterators (gfc_forall_iterator
*it
)
6678 gfc_forall_iterator
*iter
, *iter2
;
6680 for (iter
= it
; iter
; iter
= iter
->next
)
6682 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6683 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6684 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6687 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6688 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6689 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6690 &iter
->start
->where
);
6691 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6692 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6694 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6695 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6696 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6698 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6699 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6701 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6703 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6704 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6705 &iter
->stride
->where
, "INTEGER");
6707 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6708 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6709 gfc_error ("FORALL stride expression at %L cannot be zero",
6710 &iter
->stride
->where
);
6712 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6713 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6716 for (iter
= it
; iter
; iter
= iter
->next
)
6717 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6719 if (find_forall_index (iter2
->start
,
6720 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6721 || find_forall_index (iter2
->end
,
6722 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6723 || find_forall_index (iter2
->stride
,
6724 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6725 gfc_error ("FORALL index '%s' may not appear in triplet "
6726 "specification at %L", iter
->var
->symtree
->name
,
6727 &iter2
->start
->where
);
6732 /* Given a pointer to a symbol that is a derived type, see if it's
6733 inaccessible, i.e. if it's defined in another module and the components are
6734 PRIVATE. The search is recursive if necessary. Returns zero if no
6735 inaccessible components are found, nonzero otherwise. */
6738 derived_inaccessible (gfc_symbol
*sym
)
6742 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6745 for (c
= sym
->components
; c
; c
= c
->next
)
6747 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6755 /* Resolve the argument of a deallocate expression. The expression must be
6756 a pointer or a full array. */
6759 resolve_deallocate_expr (gfc_expr
*e
)
6761 symbol_attribute attr
;
6762 int allocatable
, pointer
;
6767 if (gfc_resolve_expr (e
) == FAILURE
)
6770 if (e
->expr_type
!= EXPR_VARIABLE
)
6773 sym
= e
->symtree
->n
.sym
;
6775 if (sym
->ts
.type
== BT_CLASS
)
6777 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6778 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6782 allocatable
= sym
->attr
.allocatable
;
6783 pointer
= sym
->attr
.pointer
;
6785 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6790 if (ref
->u
.ar
.type
!= AR_FULL
6791 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6792 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6797 c
= ref
->u
.c
.component
;
6798 if (c
->ts
.type
== BT_CLASS
)
6800 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6801 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6805 allocatable
= c
->attr
.allocatable
;
6806 pointer
= c
->attr
.pointer
;
6816 attr
= gfc_expr_attr (e
);
6818 if (allocatable
== 0 && attr
.pointer
== 0)
6821 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6827 if (gfc_is_coindexed (e
))
6829 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6834 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6837 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6845 /* Returns true if the expression e contains a reference to the symbol sym. */
6847 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6849 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6856 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6858 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6862 /* Given the expression node e for an allocatable/pointer of derived type to be
6863 allocated, get the expression node to be initialized afterwards (needed for
6864 derived types with default initializers, and derived types with allocatable
6865 components that need nullification.) */
6868 gfc_expr_to_initialize (gfc_expr
*e
)
6874 result
= gfc_copy_expr (e
);
6876 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6877 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6878 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6880 ref
->u
.ar
.type
= AR_FULL
;
6882 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6883 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6888 gfc_free_shape (&result
->shape
, result
->rank
);
6890 /* Recalculate rank, shape, etc. */
6891 gfc_resolve_expr (result
);
6896 /* If the last ref of an expression is an array ref, return a copy of the
6897 expression with that one removed. Otherwise, a copy of the original
6898 expression. This is used for allocate-expressions and pointer assignment
6899 LHS, where there may be an array specification that needs to be stripped
6900 off when using gfc_check_vardef_context. */
6903 remove_last_array_ref (gfc_expr
* e
)
6908 e2
= gfc_copy_expr (e
);
6909 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6910 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6912 gfc_free_ref_list (*r
);
6921 /* Used in resolve_allocate_expr to check that a allocation-object and
6922 a source-expr are conformable. This does not catch all possible
6923 cases; in particular a runtime checking is needed. */
6926 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6929 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6931 /* First compare rank. */
6932 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6934 gfc_error ("Source-expr at %L must be scalar or have the "
6935 "same rank as the allocate-object at %L",
6936 &e1
->where
, &e2
->where
);
6947 for (i
= 0; i
< e1
->rank
; i
++)
6949 if (tail
->u
.ar
.end
[i
])
6951 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6952 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6953 mpz_add_ui (s
, s
, 1);
6957 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6960 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6962 gfc_error ("Source-expr at %L and allocate-object at %L must "
6963 "have the same shape", &e1
->where
, &e2
->where
);
6976 /* Resolve the expression in an ALLOCATE statement, doing the additional
6977 checks to see whether the expression is OK or not. The expression must
6978 have a trailing array reference that gives the size of the array. */
6981 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6983 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6986 symbol_attribute attr
;
6987 gfc_ref
*ref
, *ref2
;
6990 gfc_symbol
*sym
= NULL
;
6995 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
6996 checking of coarrays. */
6997 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6998 if (ref
->next
== NULL
)
7001 if (ref
&& ref
->type
== REF_ARRAY
)
7002 ref
->u
.ar
.in_allocate
= true;
7004 if (gfc_resolve_expr (e
) == FAILURE
)
7007 /* Make sure the expression is allocatable or a pointer. If it is
7008 pointer, the next-to-last reference must be a pointer. */
7012 sym
= e
->symtree
->n
.sym
;
7014 /* Check whether ultimate component is abstract and CLASS. */
7017 if (e
->expr_type
!= EXPR_VARIABLE
)
7020 attr
= gfc_expr_attr (e
);
7021 pointer
= attr
.pointer
;
7022 dimension
= attr
.dimension
;
7023 codimension
= attr
.codimension
;
7027 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7029 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7030 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7031 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7032 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7033 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7037 allocatable
= sym
->attr
.allocatable
;
7038 pointer
= sym
->attr
.pointer
;
7039 dimension
= sym
->attr
.dimension
;
7040 codimension
= sym
->attr
.codimension
;
7045 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7050 if (ref
->u
.ar
.codimen
> 0)
7053 for (n
= ref
->u
.ar
.dimen
;
7054 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7055 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7062 if (ref
->next
!= NULL
)
7070 gfc_error ("Coindexed allocatable object at %L",
7075 c
= ref
->u
.c
.component
;
7076 if (c
->ts
.type
== BT_CLASS
)
7078 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7079 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7080 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7081 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7082 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7086 allocatable
= c
->attr
.allocatable
;
7087 pointer
= c
->attr
.pointer
;
7088 dimension
= c
->attr
.dimension
;
7089 codimension
= c
->attr
.codimension
;
7090 is_abstract
= c
->attr
.abstract
;
7102 /* Check for F08:C628. */
7103 if (allocatable
== 0 && pointer
== 0)
7105 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7110 /* Some checks for the SOURCE tag. */
7113 /* Check F03:C631. */
7114 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7116 gfc_error ("Type of entity at %L is type incompatible with "
7117 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7121 /* Check F03:C632 and restriction following Note 6.18. */
7122 if (code
->expr3
->rank
> 0
7123 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
7126 /* Check F03:C633. */
7127 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
7129 gfc_error ("The allocate-object at %L and the source-expr at %L "
7130 "shall have the same kind type parameter",
7131 &e
->where
, &code
->expr3
->where
);
7135 /* Check F2008, C642. */
7136 if (code
->expr3
->ts
.type
== BT_DERIVED
7137 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7138 || (code
->expr3
->ts
.u
.derived
->from_intmod
7139 == INTMOD_ISO_FORTRAN_ENV
7140 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7141 == ISOFORTRAN_LOCK_TYPE
)))
7143 gfc_error ("The source-expr at %L shall neither be of type "
7144 "LOCK_TYPE nor have a LOCK_TYPE component if "
7145 "allocate-object at %L is a coarray",
7146 &code
->expr3
->where
, &e
->where
);
7151 /* Check F08:C629. */
7152 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7155 gcc_assert (e
->ts
.type
== BT_CLASS
);
7156 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7157 "type-spec or source-expr", sym
->name
, &e
->where
);
7161 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
7163 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7164 code
->ext
.alloc
.ts
.u
.cl
->length
);
7165 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7167 gfc_error ("Allocating %s at %L with type-spec requires the same "
7168 "character-length parameter as in the declaration",
7169 sym
->name
, &e
->where
);
7174 /* In the variable definition context checks, gfc_expr_attr is used
7175 on the expression. This is fooled by the array specification
7176 present in e, thus we have to eliminate that one temporarily. */
7177 e2
= remove_last_array_ref (e
);
7179 if (t
== SUCCESS
&& pointer
)
7180 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
7182 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
7187 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7188 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7190 /* For class arrays, the initialization with SOURCE is done
7191 using _copy and trans_call. It is convenient to exploit that
7192 when the allocated type is different from the declared type but
7193 no SOURCE exists by setting expr3. */
7194 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7196 else if (!code
->expr3
)
7198 /* Set up default initializer if needed. */
7202 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7203 ts
= code
->ext
.alloc
.ts
;
7207 if (ts
.type
== BT_CLASS
)
7208 ts
= ts
.u
.derived
->components
->ts
;
7210 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7212 gfc_code
*init_st
= gfc_get_code ();
7213 init_st
->loc
= code
->loc
;
7214 init_st
->op
= EXEC_INIT_ASSIGN
;
7215 init_st
->expr1
= gfc_expr_to_initialize (e
);
7216 init_st
->expr2
= init_e
;
7217 init_st
->next
= code
->next
;
7218 code
->next
= init_st
;
7221 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7223 /* Default initialization via MOLD (non-polymorphic). */
7224 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7225 gfc_resolve_expr (rhs
);
7226 gfc_free_expr (code
->expr3
);
7230 if (e
->ts
.type
== BT_CLASS
)
7232 /* Make sure the vtab symbol is present when
7233 the module variables are generated. */
7234 gfc_typespec ts
= e
->ts
;
7236 ts
= code
->expr3
->ts
;
7237 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7238 ts
= code
->ext
.alloc
.ts
;
7239 gfc_find_derived_vtab (ts
.u
.derived
);
7241 e
= gfc_expr_to_initialize (e
);
7244 if (dimension
== 0 && codimension
== 0)
7247 /* Make sure the last reference node is an array specification. */
7249 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7250 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7252 gfc_error ("Array specification required in ALLOCATE statement "
7253 "at %L", &e
->where
);
7257 /* Make sure that the array section reference makes sense in the
7258 context of an ALLOCATE specification. */
7263 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7264 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7266 gfc_error ("Coarray specification required in ALLOCATE statement "
7267 "at %L", &e
->where
);
7271 for (i
= 0; i
< ar
->dimen
; i
++)
7273 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7276 switch (ar
->dimen_type
[i
])
7282 if (ar
->start
[i
] != NULL
7283 && ar
->end
[i
] != NULL
7284 && ar
->stride
[i
] == NULL
)
7287 /* Fall Through... */
7292 case DIMEN_THIS_IMAGE
:
7293 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7299 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7301 sym
= a
->expr
->symtree
->n
.sym
;
7303 /* TODO - check derived type components. */
7304 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7307 if ((ar
->start
[i
] != NULL
7308 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7309 || (ar
->end
[i
] != NULL
7310 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7312 gfc_error ("'%s' must not appear in the array specification at "
7313 "%L in the same ALLOCATE statement where it is "
7314 "itself allocated", sym
->name
, &ar
->where
);
7320 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7322 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7323 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7325 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7327 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7328 "statement at %L", &e
->where
);
7334 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7335 && ar
->stride
[i
] == NULL
)
7338 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7351 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7353 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7354 gfc_alloc
*a
, *p
, *q
;
7357 errmsg
= code
->expr2
;
7359 /* Check the stat variable. */
7362 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7364 if ((stat
->ts
.type
!= BT_INTEGER
7365 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7366 || stat
->ref
->type
== REF_COMPONENT
)))
7368 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7369 "variable", &stat
->where
);
7371 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7372 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7374 gfc_ref
*ref1
, *ref2
;
7377 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7378 ref1
= ref1
->next
, ref2
= ref2
->next
)
7380 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7382 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7391 gfc_error ("Stat-variable at %L shall not be %sd within "
7392 "the same %s statement", &stat
->where
, fcn
, fcn
);
7398 /* Check the errmsg variable. */
7402 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7405 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7407 if ((errmsg
->ts
.type
!= BT_CHARACTER
7409 && (errmsg
->ref
->type
== REF_ARRAY
7410 || errmsg
->ref
->type
== REF_COMPONENT
)))
7411 || errmsg
->rank
> 0 )
7412 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7413 "variable", &errmsg
->where
);
7415 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7416 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7418 gfc_ref
*ref1
, *ref2
;
7421 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7422 ref1
= ref1
->next
, ref2
= ref2
->next
)
7424 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7426 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7435 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7436 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7442 /* Check that an allocate-object appears only once in the statement. */
7444 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7447 for (q
= p
->next
; q
; q
= q
->next
)
7450 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7452 /* This is a potential collision. */
7453 gfc_ref
*pr
= pe
->ref
;
7454 gfc_ref
*qr
= qe
->ref
;
7456 /* Follow the references until
7457 a) They start to differ, in which case there is no error;
7458 you can deallocate a%b and a%c in a single statement
7459 b) Both of them stop, which is an error
7460 c) One of them stops, which is also an error. */
7463 if (pr
== NULL
&& qr
== NULL
)
7465 gfc_error ("Allocate-object at %L also appears at %L",
7466 &pe
->where
, &qe
->where
);
7469 else if (pr
!= NULL
&& qr
== NULL
)
7471 gfc_error ("Allocate-object at %L is subobject of"
7472 " object at %L", &pe
->where
, &qe
->where
);
7475 else if (pr
== NULL
&& qr
!= NULL
)
7477 gfc_error ("Allocate-object at %L is subobject of"
7478 " object at %L", &qe
->where
, &pe
->where
);
7481 /* Here, pr != NULL && qr != NULL */
7482 gcc_assert(pr
->type
== qr
->type
);
7483 if (pr
->type
== REF_ARRAY
)
7485 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7487 gcc_assert (qr
->type
== REF_ARRAY
);
7489 if (pr
->next
&& qr
->next
)
7491 gfc_array_ref
*par
= &(pr
->u
.ar
);
7492 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7493 if ((par
->start
[0] != NULL
|| qar
->start
[0] != NULL
)
7494 && gfc_dep_compare_expr (par
->start
[0],
7495 qar
->start
[0]) != 0)
7501 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7512 if (strcmp (fcn
, "ALLOCATE") == 0)
7514 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7515 resolve_allocate_expr (a
->expr
, code
);
7519 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7520 resolve_deallocate_expr (a
->expr
);
7525 /************ SELECT CASE resolution subroutines ************/
7527 /* Callback function for our mergesort variant. Determines interval
7528 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7529 op1 > op2. Assumes we're not dealing with the default case.
7530 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7531 There are nine situations to check. */
7534 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7538 if (op1
->low
== NULL
) /* op1 = (:L) */
7540 /* op2 = (:N), so overlap. */
7542 /* op2 = (M:) or (M:N), L < M */
7543 if (op2
->low
!= NULL
7544 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7547 else if (op1
->high
== NULL
) /* op1 = (K:) */
7549 /* op2 = (M:), so overlap. */
7551 /* op2 = (:N) or (M:N), K > N */
7552 if (op2
->high
!= NULL
7553 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7556 else /* op1 = (K:L) */
7558 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7559 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7561 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7562 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7564 else /* op2 = (M:N) */
7568 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7571 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7580 /* Merge-sort a double linked case list, detecting overlap in the
7581 process. LIST is the head of the double linked case list before it
7582 is sorted. Returns the head of the sorted list if we don't see any
7583 overlap, or NULL otherwise. */
7586 check_case_overlap (gfc_case
*list
)
7588 gfc_case
*p
, *q
, *e
, *tail
;
7589 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7591 /* If the passed list was empty, return immediately. */
7598 /* Loop unconditionally. The only exit from this loop is a return
7599 statement, when we've finished sorting the case list. */
7606 /* Count the number of merges we do in this pass. */
7609 /* Loop while there exists a merge to be done. */
7614 /* Count this merge. */
7617 /* Cut the list in two pieces by stepping INSIZE places
7618 forward in the list, starting from P. */
7621 for (i
= 0; i
< insize
; i
++)
7630 /* Now we have two lists. Merge them! */
7631 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7633 /* See from which the next case to merge comes from. */
7636 /* P is empty so the next case must come from Q. */
7641 else if (qsize
== 0 || q
== NULL
)
7650 cmp
= compare_cases (p
, q
);
7653 /* The whole case range for P is less than the
7661 /* The whole case range for Q is greater than
7662 the case range for P. */
7669 /* The cases overlap, or they are the same
7670 element in the list. Either way, we must
7671 issue an error and get the next case from P. */
7672 /* FIXME: Sort P and Q by line number. */
7673 gfc_error ("CASE label at %L overlaps with CASE "
7674 "label at %L", &p
->where
, &q
->where
);
7682 /* Add the next element to the merged list. */
7691 /* P has now stepped INSIZE places along, and so has Q. So
7692 they're the same. */
7697 /* If we have done only one merge or none at all, we've
7698 finished sorting the cases. */
7707 /* Otherwise repeat, merging lists twice the size. */
7713 /* Check to see if an expression is suitable for use in a CASE statement.
7714 Makes sure that all case expressions are scalar constants of the same
7715 type. Return FAILURE if anything is wrong. */
7718 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7720 if (e
== NULL
) return SUCCESS
;
7722 if (e
->ts
.type
!= case_expr
->ts
.type
)
7724 gfc_error ("Expression in CASE statement at %L must be of type %s",
7725 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7729 /* C805 (R808) For a given case-construct, each case-value shall be of
7730 the same type as case-expr. For character type, length differences
7731 are allowed, but the kind type parameters shall be the same. */
7733 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7735 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7736 &e
->where
, case_expr
->ts
.kind
);
7740 /* Convert the case value kind to that of case expression kind,
7743 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7744 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7748 gfc_error ("Expression in CASE statement at %L must be scalar",
7757 /* Given a completely parsed select statement, we:
7759 - Validate all expressions and code within the SELECT.
7760 - Make sure that the selection expression is not of the wrong type.
7761 - Make sure that no case ranges overlap.
7762 - Eliminate unreachable cases and unreachable code resulting from
7763 removing case labels.
7765 The standard does allow unreachable cases, e.g. CASE (5:3). But
7766 they are a hassle for code generation, and to prevent that, we just
7767 cut them out here. This is not necessary for overlapping cases
7768 because they are illegal and we never even try to generate code.
7770 We have the additional caveat that a SELECT construct could have
7771 been a computed GOTO in the source code. Fortunately we can fairly
7772 easily work around that here: The case_expr for a "real" SELECT CASE
7773 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7774 we have to do is make sure that the case_expr is a scalar integer
7778 resolve_select (gfc_code
*code
)
7781 gfc_expr
*case_expr
;
7782 gfc_case
*cp
, *default_case
, *tail
, *head
;
7783 int seen_unreachable
;
7789 if (code
->expr1
== NULL
)
7791 /* This was actually a computed GOTO statement. */
7792 case_expr
= code
->expr2
;
7793 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7794 gfc_error ("Selection expression in computed GOTO statement "
7795 "at %L must be a scalar integer expression",
7798 /* Further checking is not necessary because this SELECT was built
7799 by the compiler, so it should always be OK. Just move the
7800 case_expr from expr2 to expr so that we can handle computed
7801 GOTOs as normal SELECTs from here on. */
7802 code
->expr1
= code
->expr2
;
7807 case_expr
= code
->expr1
;
7809 type
= case_expr
->ts
.type
;
7810 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7812 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7813 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7815 /* Punt. Going on here just produce more garbage error messages. */
7819 /* Raise a warning if an INTEGER case value exceeds the range of
7820 the case-expr. Later, all expressions will be promoted to the
7821 largest kind of all case-labels. */
7823 if (type
== BT_INTEGER
)
7824 for (body
= code
->block
; body
; body
= body
->block
)
7825 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7828 && gfc_check_integer_range (cp
->low
->value
.integer
,
7829 case_expr
->ts
.kind
) != ARITH_OK
)
7830 gfc_warning ("Expression in CASE statement at %L is "
7831 "not in the range of %s", &cp
->low
->where
,
7832 gfc_typename (&case_expr
->ts
));
7835 && cp
->low
!= cp
->high
7836 && gfc_check_integer_range (cp
->high
->value
.integer
,
7837 case_expr
->ts
.kind
) != ARITH_OK
)
7838 gfc_warning ("Expression in CASE statement at %L is "
7839 "not in the range of %s", &cp
->high
->where
,
7840 gfc_typename (&case_expr
->ts
));
7843 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7844 of the SELECT CASE expression and its CASE values. Walk the lists
7845 of case values, and if we find a mismatch, promote case_expr to
7846 the appropriate kind. */
7848 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7850 for (body
= code
->block
; body
; body
= body
->block
)
7852 /* Walk the case label list. */
7853 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7855 /* Intercept the DEFAULT case. It does not have a kind. */
7856 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7859 /* Unreachable case ranges are discarded, so ignore. */
7860 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7861 && cp
->low
!= cp
->high
7862 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7866 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7867 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7869 if (cp
->high
!= NULL
7870 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7871 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7876 /* Assume there is no DEFAULT case. */
7877 default_case
= NULL
;
7882 for (body
= code
->block
; body
; body
= body
->block
)
7884 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7886 seen_unreachable
= 0;
7888 /* Walk the case label list, making sure that all case labels
7890 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7892 /* Count the number of cases in the whole construct. */
7895 /* Intercept the DEFAULT case. */
7896 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7898 if (default_case
!= NULL
)
7900 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7901 "by a second DEFAULT CASE at %L",
7902 &default_case
->where
, &cp
->where
);
7913 /* Deal with single value cases and case ranges. Errors are
7914 issued from the validation function. */
7915 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7916 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7922 if (type
== BT_LOGICAL
7923 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7924 || cp
->low
!= cp
->high
))
7926 gfc_error ("Logical range in CASE statement at %L is not "
7927 "allowed", &cp
->low
->where
);
7932 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7935 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7936 if (value
& seen_logical
)
7938 gfc_error ("Constant logical value in CASE statement "
7939 "is repeated at %L",
7944 seen_logical
|= value
;
7947 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7948 && cp
->low
!= cp
->high
7949 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7951 if (gfc_option
.warn_surprising
)
7952 gfc_warning ("Range specification at %L can never "
7953 "be matched", &cp
->where
);
7955 cp
->unreachable
= 1;
7956 seen_unreachable
= 1;
7960 /* If the case range can be matched, it can also overlap with
7961 other cases. To make sure it does not, we put it in a
7962 double linked list here. We sort that with a merge sort
7963 later on to detect any overlapping cases. */
7967 head
->right
= head
->left
= NULL
;
7972 tail
->right
->left
= tail
;
7979 /* It there was a failure in the previous case label, give up
7980 for this case label list. Continue with the next block. */
7984 /* See if any case labels that are unreachable have been seen.
7985 If so, we eliminate them. This is a bit of a kludge because
7986 the case lists for a single case statement (label) is a
7987 single forward linked lists. */
7988 if (seen_unreachable
)
7990 /* Advance until the first case in the list is reachable. */
7991 while (body
->ext
.block
.case_list
!= NULL
7992 && body
->ext
.block
.case_list
->unreachable
)
7994 gfc_case
*n
= body
->ext
.block
.case_list
;
7995 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7997 gfc_free_case_list (n
);
8000 /* Strip all other unreachable cases. */
8001 if (body
->ext
.block
.case_list
)
8003 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
8005 if (cp
->next
->unreachable
)
8007 gfc_case
*n
= cp
->next
;
8008 cp
->next
= cp
->next
->next
;
8010 gfc_free_case_list (n
);
8017 /* See if there were overlapping cases. If the check returns NULL,
8018 there was overlap. In that case we don't do anything. If head
8019 is non-NULL, we prepend the DEFAULT case. The sorted list can
8020 then used during code generation for SELECT CASE constructs with
8021 a case expression of a CHARACTER type. */
8024 head
= check_case_overlap (head
);
8026 /* Prepend the default_case if it is there. */
8027 if (head
!= NULL
&& default_case
)
8029 default_case
->left
= NULL
;
8030 default_case
->right
= head
;
8031 head
->left
= default_case
;
8035 /* Eliminate dead blocks that may be the result if we've seen
8036 unreachable case labels for a block. */
8037 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8039 if (body
->block
->ext
.block
.case_list
== NULL
)
8041 /* Cut the unreachable block from the code chain. */
8042 gfc_code
*c
= body
->block
;
8043 body
->block
= c
->block
;
8045 /* Kill the dead block, but not the blocks below it. */
8047 gfc_free_statements (c
);
8051 /* More than two cases is legal but insane for logical selects.
8052 Issue a warning for it. */
8053 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
8055 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
8060 /* Check if a derived type is extensible. */
8063 gfc_type_is_extensible (gfc_symbol
*sym
)
8065 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
8069 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8070 correct as well as possibly the array-spec. */
8073 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8077 gcc_assert (sym
->assoc
);
8078 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8080 /* If this is for SELECT TYPE, the target may not yet be set. In that
8081 case, return. Resolution will be called later manually again when
8083 target
= sym
->assoc
->target
;
8086 gcc_assert (!sym
->assoc
->dangling
);
8088 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
8091 /* For variable targets, we get some attributes from the target. */
8092 if (target
->expr_type
== EXPR_VARIABLE
)
8096 gcc_assert (target
->symtree
);
8097 tsym
= target
->symtree
->n
.sym
;
8099 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8100 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8102 sym
->attr
.target
= tsym
->attr
.target
8103 || gfc_expr_attr (target
).pointer
;
8106 /* Get type if this was not already set. Note that it can be
8107 some other type than the target in case this is a SELECT TYPE
8108 selector! So we must not update when the type is already there. */
8109 if (sym
->ts
.type
== BT_UNKNOWN
)
8110 sym
->ts
= target
->ts
;
8111 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8113 /* See if this is a valid association-to-variable. */
8114 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8115 && !gfc_has_vector_subscript (target
));
8117 /* Finally resolve if this is an array or not. */
8118 if (sym
->attr
.dimension
&& target
->rank
== 0)
8120 gfc_error ("Associate-name '%s' at %L is used as array",
8121 sym
->name
, &sym
->declared_at
);
8122 sym
->attr
.dimension
= 0;
8126 /* We cannot deal with class selectors that need temporaries. */
8127 if (target
->ts
.type
== BT_CLASS
8128 && gfc_ref_needs_temporary_p (target
->ref
))
8130 gfc_error ("CLASS selector at %L needs a temporary which is not "
8131 "yet implemented", &target
->where
);
8135 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8136 sym
->attr
.dimension
= 1;
8137 else if (target
->ts
.type
== BT_CLASS
)
8138 gfc_fix_class_refs (target
);
8140 /* The associate-name will have a correct type by now. Make absolutely
8141 sure that it has not picked up a dimension attribute. */
8142 if (sym
->ts
.type
== BT_CLASS
)
8143 sym
->attr
.dimension
= 0;
8145 if (sym
->attr
.dimension
)
8147 sym
->as
= gfc_get_array_spec ();
8148 sym
->as
->rank
= target
->rank
;
8149 sym
->as
->type
= AS_DEFERRED
;
8151 /* Target must not be coindexed, thus the associate-variable
8153 sym
->as
->corank
= 0;
8158 /* Resolve a SELECT TYPE statement. */
8161 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8163 gfc_symbol
*selector_type
;
8164 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8165 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8168 char name
[GFC_MAX_SYMBOL_LEN
];
8172 ns
= code
->ext
.block
.ns
;
8175 /* Check for F03:C813. */
8176 if (code
->expr1
->ts
.type
!= BT_CLASS
8177 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8179 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8180 "at %L", &code
->loc
);
8184 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8189 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8190 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8191 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8194 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8196 /* Loop over TYPE IS / CLASS IS cases. */
8197 for (body
= code
->block
; body
; body
= body
->block
)
8199 c
= body
->ext
.block
.case_list
;
8201 /* Check F03:C815. */
8202 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8203 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8205 gfc_error ("Derived type '%s' at %L must be extensible",
8206 c
->ts
.u
.derived
->name
, &c
->where
);
8211 /* Check F03:C816. */
8212 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8213 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
8215 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8216 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8221 /* Intercept the DEFAULT case. */
8222 if (c
->ts
.type
== BT_UNKNOWN
)
8224 /* Check F03:C818. */
8227 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8228 "by a second DEFAULT CASE at %L",
8229 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8234 default_case
= body
;
8241 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8242 target if present. If there are any EXIT statements referring to the
8243 SELECT TYPE construct, this is no problem because the gfc_code
8244 reference stays the same and EXIT is equally possible from the BLOCK
8245 it is changed to. */
8246 code
->op
= EXEC_BLOCK
;
8249 gfc_association_list
* assoc
;
8251 assoc
= gfc_get_association_list ();
8252 assoc
->st
= code
->expr1
->symtree
;
8253 assoc
->target
= gfc_copy_expr (code
->expr2
);
8254 assoc
->target
->where
= code
->expr2
->where
;
8255 /* assoc->variable will be set by resolve_assoc_var. */
8257 code
->ext
.block
.assoc
= assoc
;
8258 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8260 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8263 code
->ext
.block
.assoc
= NULL
;
8265 /* Add EXEC_SELECT to switch on type. */
8266 new_st
= gfc_get_code ();
8267 new_st
->op
= code
->op
;
8268 new_st
->expr1
= code
->expr1
;
8269 new_st
->expr2
= code
->expr2
;
8270 new_st
->block
= code
->block
;
8271 code
->expr1
= code
->expr2
= NULL
;
8276 ns
->code
->next
= new_st
;
8278 code
->op
= EXEC_SELECT
;
8279 gfc_add_vptr_component (code
->expr1
);
8280 gfc_add_hash_component (code
->expr1
);
8282 /* Loop over TYPE IS / CLASS IS cases. */
8283 for (body
= code
->block
; body
; body
= body
->block
)
8285 c
= body
->ext
.block
.case_list
;
8287 if (c
->ts
.type
== BT_DERIVED
)
8288 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8289 c
->ts
.u
.derived
->hash_value
);
8291 else if (c
->ts
.type
== BT_UNKNOWN
)
8294 /* Associate temporary to selector. This should only be done
8295 when this case is actually true, so build a new ASSOCIATE
8296 that does precisely this here (instead of using the
8299 if (c
->ts
.type
== BT_CLASS
)
8300 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8302 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8303 st
= gfc_find_symtree (ns
->sym_root
, name
);
8304 gcc_assert (st
->n
.sym
->assoc
);
8305 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8306 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8307 if (c
->ts
.type
== BT_DERIVED
)
8308 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8310 new_st
= gfc_get_code ();
8311 new_st
->op
= EXEC_BLOCK
;
8312 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8313 new_st
->ext
.block
.ns
->code
= body
->next
;
8314 body
->next
= new_st
;
8316 /* Chain in the new list only if it is marked as dangling. Otherwise
8317 there is a CASE label overlap and this is already used. Just ignore,
8318 the error is diagnosed elsewhere. */
8319 if (st
->n
.sym
->assoc
->dangling
)
8321 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8322 st
->n
.sym
->assoc
->dangling
= 0;
8325 resolve_assoc_var (st
->n
.sym
, false);
8328 /* Take out CLASS IS cases for separate treatment. */
8330 while (body
&& body
->block
)
8332 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8334 /* Add to class_is list. */
8335 if (class_is
== NULL
)
8337 class_is
= body
->block
;
8342 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8343 tail
->block
= body
->block
;
8346 /* Remove from EXEC_SELECT list. */
8347 body
->block
= body
->block
->block
;
8360 /* Add a default case to hold the CLASS IS cases. */
8361 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8362 tail
->block
= gfc_get_code ();
8364 tail
->op
= EXEC_SELECT_TYPE
;
8365 tail
->ext
.block
.case_list
= gfc_get_case ();
8366 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8368 default_case
= tail
;
8371 /* More than one CLASS IS block? */
8372 if (class_is
->block
)
8376 /* Sort CLASS IS blocks by extension level. */
8380 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8383 /* F03:C817 (check for doubles). */
8384 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8385 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8387 gfc_error ("Double CLASS IS block in SELECT TYPE "
8389 &c2
->ext
.block
.case_list
->where
);
8392 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8393 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8396 (*c1
)->block
= c2
->block
;
8406 /* Generate IF chain. */
8407 if_st
= gfc_get_code ();
8408 if_st
->op
= EXEC_IF
;
8410 for (body
= class_is
; body
; body
= body
->block
)
8412 new_st
->block
= gfc_get_code ();
8413 new_st
= new_st
->block
;
8414 new_st
->op
= EXEC_IF
;
8415 /* Set up IF condition: Call _gfortran_is_extension_of. */
8416 new_st
->expr1
= gfc_get_expr ();
8417 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8418 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8419 new_st
->expr1
->ts
.kind
= 4;
8420 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8421 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8422 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8423 /* Set up arguments. */
8424 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8425 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8426 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8427 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8428 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8429 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8430 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8431 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8432 new_st
->next
= body
->next
;
8434 if (default_case
->next
)
8436 new_st
->block
= gfc_get_code ();
8437 new_st
= new_st
->block
;
8438 new_st
->op
= EXEC_IF
;
8439 new_st
->next
= default_case
->next
;
8442 /* Replace CLASS DEFAULT code by the IF chain. */
8443 default_case
->next
= if_st
;
8446 /* Resolve the internal code. This can not be done earlier because
8447 it requires that the sym->assoc of selectors is set already. */
8448 gfc_current_ns
= ns
;
8449 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8450 gfc_current_ns
= old_ns
;
8452 resolve_select (code
);
8456 /* Resolve a transfer statement. This is making sure that:
8457 -- a derived type being transferred has only non-pointer components
8458 -- a derived type being transferred doesn't have private components, unless
8459 it's being transferred from the module where the type was defined
8460 -- we're not trying to transfer a whole assumed size array. */
8463 resolve_transfer (gfc_code
*code
)
8472 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8473 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8474 exp
= exp
->value
.op
.op1
;
8476 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8478 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8479 "MOLD=", &exp
->where
);
8483 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8484 && exp
->expr_type
!= EXPR_FUNCTION
))
8487 /* If we are reading, the variable will be changed. Note that
8488 code->ext.dt may be NULL if the TRANSFER is related to
8489 an INQUIRE statement -- but in this case, we are not reading, either. */
8490 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8491 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8495 sym
= exp
->symtree
->n
.sym
;
8498 /* Go to actual component transferred. */
8499 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8500 if (ref
->type
== REF_COMPONENT
)
8501 ts
= &ref
->u
.c
.component
->ts
;
8503 if (ts
->type
== BT_CLASS
)
8505 /* FIXME: Test for defined input/output. */
8506 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8507 "it is processed by a defined input/output procedure",
8512 if (ts
->type
== BT_DERIVED
)
8514 /* Check that transferred derived type doesn't contain POINTER
8516 if (ts
->u
.derived
->attr
.pointer_comp
)
8518 gfc_error ("Data transfer element at %L cannot have POINTER "
8519 "components unless it is processed by a defined "
8520 "input/output procedure", &code
->loc
);
8525 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8527 gfc_error ("Data transfer element at %L cannot have "
8528 "procedure pointer components", &code
->loc
);
8532 if (ts
->u
.derived
->attr
.alloc_comp
)
8534 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8535 "components unless it is processed by a defined "
8536 "input/output procedure", &code
->loc
);
8540 if (derived_inaccessible (ts
->u
.derived
))
8542 gfc_error ("Data transfer element at %L cannot have "
8543 "PRIVATE components",&code
->loc
);
8548 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8549 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8551 gfc_error ("Data transfer element at %L cannot be a full reference to "
8552 "an assumed-size array", &code
->loc
);
8558 /*********** Toplevel code resolution subroutines ***********/
8560 /* Find the set of labels that are reachable from this block. We also
8561 record the last statement in each block. */
8564 find_reachable_labels (gfc_code
*block
)
8571 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8573 /* Collect labels in this block. We don't keep those corresponding
8574 to END {IF|SELECT}, these are checked in resolve_branch by going
8575 up through the code_stack. */
8576 for (c
= block
; c
; c
= c
->next
)
8578 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8579 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8582 /* Merge with labels from parent block. */
8585 gcc_assert (cs_base
->prev
->reachable_labels
);
8586 bitmap_ior_into (cs_base
->reachable_labels
,
8587 cs_base
->prev
->reachable_labels
);
8593 resolve_lock_unlock (gfc_code
*code
)
8595 if (code
->expr1
->ts
.type
!= BT_DERIVED
8596 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8597 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8598 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8599 || code
->expr1
->rank
!= 0
8600 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8601 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8602 &code
->expr1
->where
);
8606 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8607 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8608 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8609 &code
->expr2
->where
);
8612 && gfc_check_vardef_context (code
->expr2
, false, false,
8613 _("STAT variable")) == FAILURE
)
8618 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8619 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8620 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8621 &code
->expr3
->where
);
8624 && gfc_check_vardef_context (code
->expr3
, false, false,
8625 _("ERRMSG variable")) == FAILURE
)
8628 /* Check ACQUIRED_LOCK. */
8630 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8631 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8632 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8633 "variable", &code
->expr4
->where
);
8636 && gfc_check_vardef_context (code
->expr4
, false, false,
8637 _("ACQUIRED_LOCK variable")) == FAILURE
)
8643 resolve_sync (gfc_code
*code
)
8645 /* Check imageset. The * case matches expr1 == NULL. */
8648 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8649 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8650 "INTEGER expression", &code
->expr1
->where
);
8651 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8652 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8653 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8654 &code
->expr1
->where
);
8655 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8656 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8658 gfc_constructor
*cons
;
8659 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8660 for (; cons
; cons
= gfc_constructor_next (cons
))
8661 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8662 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8663 gfc_error ("Imageset argument at %L must between 1 and "
8664 "num_images()", &cons
->expr
->where
);
8670 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8671 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8672 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8673 &code
->expr2
->where
);
8677 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8678 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8679 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8680 &code
->expr3
->where
);
8684 /* Given a branch to a label, see if the branch is conforming.
8685 The code node describes where the branch is located. */
8688 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8695 /* Step one: is this a valid branching target? */
8697 if (label
->defined
== ST_LABEL_UNKNOWN
)
8699 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8704 if (label
->defined
!= ST_LABEL_TARGET
)
8706 gfc_error ("Statement at %L is not a valid branch target statement "
8707 "for the branch statement at %L", &label
->where
, &code
->loc
);
8711 /* Step two: make sure this branch is not a branch to itself ;-) */
8713 if (code
->here
== label
)
8715 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8719 /* Step three: See if the label is in the same block as the
8720 branching statement. The hard work has been done by setting up
8721 the bitmap reachable_labels. */
8723 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8725 /* Check now whether there is a CRITICAL construct; if so, check
8726 whether the label is still visible outside of the CRITICAL block,
8727 which is invalid. */
8728 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8730 if (stack
->current
->op
== EXEC_CRITICAL
8731 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8732 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8733 "label at %L", &code
->loc
, &label
->where
);
8734 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8735 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8736 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8737 "for label at %L", &code
->loc
, &label
->where
);
8743 /* Step four: If we haven't found the label in the bitmap, it may
8744 still be the label of the END of the enclosing block, in which
8745 case we find it by going up the code_stack. */
8747 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8749 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8751 if (stack
->current
->op
== EXEC_CRITICAL
)
8753 /* Note: A label at END CRITICAL does not leave the CRITICAL
8754 construct as END CRITICAL is still part of it. */
8755 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8756 " at %L", &code
->loc
, &label
->where
);
8759 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8761 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8762 "label at %L", &code
->loc
, &label
->where
);
8769 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8773 /* The label is not in an enclosing block, so illegal. This was
8774 allowed in Fortran 66, so we allow it as extension. No
8775 further checks are necessary in this case. */
8776 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8777 "as the GOTO statement at %L", &label
->where
,
8783 /* Check whether EXPR1 has the same shape as EXPR2. */
8786 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8788 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8789 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8790 gfc_try result
= FAILURE
;
8793 /* Compare the rank. */
8794 if (expr1
->rank
!= expr2
->rank
)
8797 /* Compare the size of each dimension. */
8798 for (i
=0; i
<expr1
->rank
; i
++)
8800 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8803 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8806 if (mpz_cmp (shape
[i
], shape2
[i
]))
8810 /* When either of the two expression is an assumed size array, we
8811 ignore the comparison of dimension sizes. */
8816 gfc_clear_shape (shape
, i
);
8817 gfc_clear_shape (shape2
, i
);
8822 /* Check whether a WHERE assignment target or a WHERE mask expression
8823 has the same shape as the outmost WHERE mask expression. */
8826 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8832 cblock
= code
->block
;
8834 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8835 In case of nested WHERE, only the outmost one is stored. */
8836 if (mask
== NULL
) /* outmost WHERE */
8838 else /* inner WHERE */
8845 /* Check if the mask-expr has a consistent shape with the
8846 outmost WHERE mask-expr. */
8847 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8848 gfc_error ("WHERE mask at %L has inconsistent shape",
8849 &cblock
->expr1
->where
);
8852 /* the assignment statement of a WHERE statement, or the first
8853 statement in where-body-construct of a WHERE construct */
8854 cnext
= cblock
->next
;
8859 /* WHERE assignment statement */
8862 /* Check shape consistent for WHERE assignment target. */
8863 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8864 gfc_error ("WHERE assignment target at %L has "
8865 "inconsistent shape", &cnext
->expr1
->where
);
8869 case EXEC_ASSIGN_CALL
:
8870 resolve_call (cnext
);
8871 if (!cnext
->resolved_sym
->attr
.elemental
)
8872 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8873 &cnext
->ext
.actual
->expr
->where
);
8876 /* WHERE or WHERE construct is part of a where-body-construct */
8878 resolve_where (cnext
, e
);
8882 gfc_error ("Unsupported statement inside WHERE at %L",
8885 /* the next statement within the same where-body-construct */
8886 cnext
= cnext
->next
;
8888 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8889 cblock
= cblock
->block
;
8894 /* Resolve assignment in FORALL construct.
8895 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8896 FORALL index variables. */
8899 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8903 for (n
= 0; n
< nvar
; n
++)
8905 gfc_symbol
*forall_index
;
8907 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8909 /* Check whether the assignment target is one of the FORALL index
8911 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8912 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8913 gfc_error ("Assignment to a FORALL index variable at %L",
8914 &code
->expr1
->where
);
8917 /* If one of the FORALL index variables doesn't appear in the
8918 assignment variable, then there could be a many-to-one
8919 assignment. Emit a warning rather than an error because the
8920 mask could be resolving this problem. */
8921 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8922 gfc_warning ("The FORALL with index '%s' is not used on the "
8923 "left side of the assignment at %L and so might "
8924 "cause multiple assignment to this object",
8925 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8931 /* Resolve WHERE statement in FORALL construct. */
8934 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8935 gfc_expr
**var_expr
)
8940 cblock
= code
->block
;
8943 /* the assignment statement of a WHERE statement, or the first
8944 statement in where-body-construct of a WHERE construct */
8945 cnext
= cblock
->next
;
8950 /* WHERE assignment statement */
8952 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8955 /* WHERE operator assignment statement */
8956 case EXEC_ASSIGN_CALL
:
8957 resolve_call (cnext
);
8958 if (!cnext
->resolved_sym
->attr
.elemental
)
8959 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8960 &cnext
->ext
.actual
->expr
->where
);
8963 /* WHERE or WHERE construct is part of a where-body-construct */
8965 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8969 gfc_error ("Unsupported statement inside WHERE at %L",
8972 /* the next statement within the same where-body-construct */
8973 cnext
= cnext
->next
;
8975 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8976 cblock
= cblock
->block
;
8981 /* Traverse the FORALL body to check whether the following errors exist:
8982 1. For assignment, check if a many-to-one assignment happens.
8983 2. For WHERE statement, check the WHERE body to see if there is any
8984 many-to-one assignment. */
8987 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8991 c
= code
->block
->next
;
8997 case EXEC_POINTER_ASSIGN
:
8998 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9001 case EXEC_ASSIGN_CALL
:
9005 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9006 there is no need to handle it here. */
9010 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9015 /* The next statement in the FORALL body. */
9021 /* Counts the number of iterators needed inside a forall construct, including
9022 nested forall constructs. This is used to allocate the needed memory
9023 in gfc_resolve_forall. */
9026 gfc_count_forall_iterators (gfc_code
*code
)
9028 int max_iters
, sub_iters
, current_iters
;
9029 gfc_forall_iterator
*fa
;
9031 gcc_assert(code
->op
== EXEC_FORALL
);
9035 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9038 code
= code
->block
->next
;
9042 if (code
->op
== EXEC_FORALL
)
9044 sub_iters
= gfc_count_forall_iterators (code
);
9045 if (sub_iters
> max_iters
)
9046 max_iters
= sub_iters
;
9051 return current_iters
+ max_iters
;
9055 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9056 gfc_resolve_forall_body to resolve the FORALL body. */
9059 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9061 static gfc_expr
**var_expr
;
9062 static int total_var
= 0;
9063 static int nvar
= 0;
9065 gfc_forall_iterator
*fa
;
9070 /* Start to resolve a FORALL construct */
9071 if (forall_save
== 0)
9073 /* Count the total number of FORALL index in the nested FORALL
9074 construct in order to allocate the VAR_EXPR with proper size. */
9075 total_var
= gfc_count_forall_iterators (code
);
9077 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9078 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9081 /* The information about FORALL iterator, including FORALL index start, end
9082 and stride. The FORALL index can not appear in start, end or stride. */
9083 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9085 /* Check if any outer FORALL index name is the same as the current
9087 for (i
= 0; i
< nvar
; i
++)
9089 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9091 gfc_error ("An outer FORALL construct already has an index "
9092 "with this name %L", &fa
->var
->where
);
9096 /* Record the current FORALL index. */
9097 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9101 /* No memory leak. */
9102 gcc_assert (nvar
<= total_var
);
9105 /* Resolve the FORALL body. */
9106 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9108 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9109 gfc_resolve_blocks (code
->block
, ns
);
9113 /* Free only the VAR_EXPRs allocated in this frame. */
9114 for (i
= nvar
; i
< tmp
; i
++)
9115 gfc_free_expr (var_expr
[i
]);
9119 /* We are in the outermost FORALL construct. */
9120 gcc_assert (forall_save
== 0);
9122 /* VAR_EXPR is not needed any more. */
9129 /* Resolve a BLOCK construct statement. */
9132 resolve_block_construct (gfc_code
* code
)
9134 /* Resolve the BLOCK's namespace. */
9135 gfc_resolve (code
->ext
.block
.ns
);
9137 /* For an ASSOCIATE block, the associations (and their targets) are already
9138 resolved during resolve_symbol. */
9142 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9145 static void resolve_code (gfc_code
*, gfc_namespace
*);
9148 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9152 for (; b
; b
= b
->block
)
9154 t
= gfc_resolve_expr (b
->expr1
);
9155 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
9161 if (t
== SUCCESS
&& b
->expr1
!= NULL
9162 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9163 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9170 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9171 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9176 resolve_branch (b
->label1
, b
);
9180 resolve_block_construct (b
);
9184 case EXEC_SELECT_TYPE
:
9188 case EXEC_DO_CONCURRENT
:
9196 case EXEC_OMP_ATOMIC
:
9197 case EXEC_OMP_CRITICAL
:
9199 case EXEC_OMP_MASTER
:
9200 case EXEC_OMP_ORDERED
:
9201 case EXEC_OMP_PARALLEL
:
9202 case EXEC_OMP_PARALLEL_DO
:
9203 case EXEC_OMP_PARALLEL_SECTIONS
:
9204 case EXEC_OMP_PARALLEL_WORKSHARE
:
9205 case EXEC_OMP_SECTIONS
:
9206 case EXEC_OMP_SINGLE
:
9208 case EXEC_OMP_TASKWAIT
:
9209 case EXEC_OMP_TASKYIELD
:
9210 case EXEC_OMP_WORKSHARE
:
9214 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9217 resolve_code (b
->next
, ns
);
9222 /* Does everything to resolve an ordinary assignment. Returns true
9223 if this is an interface assignment. */
9225 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9235 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9239 if (code
->op
== EXEC_ASSIGN_CALL
)
9241 lhs
= code
->ext
.actual
->expr
;
9242 rhsptr
= &code
->ext
.actual
->next
->expr
;
9246 gfc_actual_arglist
* args
;
9247 gfc_typebound_proc
* tbp
;
9249 gcc_assert (code
->op
== EXEC_COMPCALL
);
9251 args
= code
->expr1
->value
.compcall
.actual
;
9253 rhsptr
= &args
->next
->expr
;
9255 tbp
= code
->expr1
->value
.compcall
.tbp
;
9256 gcc_assert (!tbp
->is_generic
);
9259 /* Make a temporary rhs when there is a default initializer
9260 and rhs is the same symbol as the lhs. */
9261 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9262 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9263 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9264 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9265 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9274 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9275 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9276 &code
->loc
) == FAILURE
)
9279 /* Handle the case of a BOZ literal on the RHS. */
9280 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9283 if (gfc_option
.warn_surprising
)
9284 gfc_warning ("BOZ literal at %L is bitwise transferred "
9285 "non-integer symbol '%s'", &code
->loc
,
9286 lhs
->symtree
->n
.sym
->name
);
9288 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9290 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9292 if (rc
== ARITH_UNDERFLOW
)
9293 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9294 ". This check can be disabled with the option "
9295 "-fno-range-check", &rhs
->where
);
9296 else if (rc
== ARITH_OVERFLOW
)
9297 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9298 ". This check can be disabled with the option "
9299 "-fno-range-check", &rhs
->where
);
9300 else if (rc
== ARITH_NAN
)
9301 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9302 ". This check can be disabled with the option "
9303 "-fno-range-check", &rhs
->where
);
9308 if (lhs
->ts
.type
== BT_CHARACTER
9309 && gfc_option
.warn_character_truncation
)
9311 if (lhs
->ts
.u
.cl
!= NULL
9312 && lhs
->ts
.u
.cl
->length
!= NULL
9313 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9314 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9316 if (rhs
->expr_type
== EXPR_CONSTANT
)
9317 rlen
= rhs
->value
.character
.length
;
9319 else if (rhs
->ts
.u
.cl
!= NULL
9320 && rhs
->ts
.u
.cl
->length
!= NULL
9321 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9322 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9324 if (rlen
&& llen
&& rlen
> llen
)
9325 gfc_warning_now ("CHARACTER expression will be truncated "
9326 "in assignment (%d/%d) at %L",
9327 llen
, rlen
, &code
->loc
);
9330 /* Ensure that a vector index expression for the lvalue is evaluated
9331 to a temporary if the lvalue symbol is referenced in it. */
9334 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9335 if (ref
->type
== REF_ARRAY
)
9337 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9338 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9339 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9340 ref
->u
.ar
.start
[n
]))
9342 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9346 if (gfc_pure (NULL
))
9348 if (lhs
->ts
.type
== BT_DERIVED
9349 && lhs
->expr_type
== EXPR_VARIABLE
9350 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9351 && rhs
->expr_type
== EXPR_VARIABLE
9352 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9353 || gfc_is_coindexed (rhs
)))
9356 if (gfc_is_coindexed (rhs
))
9357 gfc_error ("Coindexed expression at %L is assigned to "
9358 "a derived type variable with a POINTER "
9359 "component in a PURE procedure",
9362 gfc_error ("The impure variable at %L is assigned to "
9363 "a derived type variable with a POINTER "
9364 "component in a PURE procedure (12.6)",
9369 /* Fortran 2008, C1283. */
9370 if (gfc_is_coindexed (lhs
))
9372 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9373 "procedure", &rhs
->where
);
9378 if (gfc_implicit_pure (NULL
))
9380 if (lhs
->expr_type
== EXPR_VARIABLE
9381 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9382 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9383 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9385 if (lhs
->ts
.type
== BT_DERIVED
9386 && lhs
->expr_type
== EXPR_VARIABLE
9387 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9388 && rhs
->expr_type
== EXPR_VARIABLE
9389 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9390 || gfc_is_coindexed (rhs
)))
9391 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9393 /* Fortran 2008, C1283. */
9394 if (gfc_is_coindexed (lhs
))
9395 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9399 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9400 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9401 if (lhs
->ts
.type
== BT_CLASS
)
9403 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9404 "%L - check that there is a matching specific subroutine "
9405 "for '=' operator", &lhs
->where
);
9409 /* F2008, Section 7.2.1.2. */
9410 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9412 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9413 "component in assignment at %L", &lhs
->where
);
9417 gfc_check_assign (lhs
, rhs
, 1);
9422 /* Given a block of code, recursively resolve everything pointed to by this
9426 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9428 int omp_workshare_save
;
9429 int forall_save
, do_concurrent_save
;
9433 frame
.prev
= cs_base
;
9437 find_reachable_labels (code
);
9439 for (; code
; code
= code
->next
)
9441 frame
.current
= code
;
9442 forall_save
= forall_flag
;
9443 do_concurrent_save
= do_concurrent_flag
;
9445 if (code
->op
== EXEC_FORALL
)
9448 gfc_resolve_forall (code
, ns
, forall_save
);
9451 else if (code
->block
)
9453 omp_workshare_save
= -1;
9456 case EXEC_OMP_PARALLEL_WORKSHARE
:
9457 omp_workshare_save
= omp_workshare_flag
;
9458 omp_workshare_flag
= 1;
9459 gfc_resolve_omp_parallel_blocks (code
, ns
);
9461 case EXEC_OMP_PARALLEL
:
9462 case EXEC_OMP_PARALLEL_DO
:
9463 case EXEC_OMP_PARALLEL_SECTIONS
:
9465 omp_workshare_save
= omp_workshare_flag
;
9466 omp_workshare_flag
= 0;
9467 gfc_resolve_omp_parallel_blocks (code
, ns
);
9470 gfc_resolve_omp_do_blocks (code
, ns
);
9472 case EXEC_SELECT_TYPE
:
9473 /* Blocks are handled in resolve_select_type because we have
9474 to transform the SELECT TYPE into ASSOCIATE first. */
9476 case EXEC_DO_CONCURRENT
:
9477 do_concurrent_flag
= 1;
9478 gfc_resolve_blocks (code
->block
, ns
);
9479 do_concurrent_flag
= 2;
9481 case EXEC_OMP_WORKSHARE
:
9482 omp_workshare_save
= omp_workshare_flag
;
9483 omp_workshare_flag
= 1;
9486 gfc_resolve_blocks (code
->block
, ns
);
9490 if (omp_workshare_save
!= -1)
9491 omp_workshare_flag
= omp_workshare_save
;
9495 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9496 t
= gfc_resolve_expr (code
->expr1
);
9497 forall_flag
= forall_save
;
9498 do_concurrent_flag
= do_concurrent_save
;
9500 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9503 if (code
->op
== EXEC_ALLOCATE
9504 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9510 case EXEC_END_BLOCK
:
9511 case EXEC_END_NESTED_BLOCK
:
9515 case EXEC_ERROR_STOP
:
9519 case EXEC_ASSIGN_CALL
:
9524 case EXEC_SYNC_IMAGES
:
9525 case EXEC_SYNC_MEMORY
:
9526 resolve_sync (code
);
9531 resolve_lock_unlock (code
);
9535 /* Keep track of which entry we are up to. */
9536 current_entry_id
= code
->ext
.entry
->id
;
9540 resolve_where (code
, NULL
);
9544 if (code
->expr1
!= NULL
)
9546 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9547 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9548 "INTEGER variable", &code
->expr1
->where
);
9549 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9550 gfc_error ("Variable '%s' has not been assigned a target "
9551 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9552 &code
->expr1
->where
);
9555 resolve_branch (code
->label1
, code
);
9559 if (code
->expr1
!= NULL
9560 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9561 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9562 "INTEGER return specifier", &code
->expr1
->where
);
9565 case EXEC_INIT_ASSIGN
:
9566 case EXEC_END_PROCEDURE
:
9573 if (gfc_check_vardef_context (code
->expr1
, false, false,
9574 _("assignment")) == FAILURE
)
9577 if (resolve_ordinary_assign (code
, ns
))
9579 if (code
->op
== EXEC_COMPCALL
)
9586 case EXEC_LABEL_ASSIGN
:
9587 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9588 gfc_error ("Label %d referenced at %L is never defined",
9589 code
->label1
->value
, &code
->label1
->where
);
9591 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9592 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9593 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9594 != gfc_default_integer_kind
9595 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9596 gfc_error ("ASSIGN statement at %L requires a scalar "
9597 "default INTEGER variable", &code
->expr1
->where
);
9600 case EXEC_POINTER_ASSIGN
:
9607 /* This is both a variable definition and pointer assignment
9608 context, so check both of them. For rank remapping, a final
9609 array ref may be present on the LHS and fool gfc_expr_attr
9610 used in gfc_check_vardef_context. Remove it. */
9611 e
= remove_last_array_ref (code
->expr1
);
9612 t
= gfc_check_vardef_context (e
, true, false,
9613 _("pointer assignment"));
9615 t
= gfc_check_vardef_context (e
, false, false,
9616 _("pointer assignment"));
9621 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9625 case EXEC_ARITHMETIC_IF
:
9627 && code
->expr1
->ts
.type
!= BT_INTEGER
9628 && code
->expr1
->ts
.type
!= BT_REAL
)
9629 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9630 "expression", &code
->expr1
->where
);
9632 resolve_branch (code
->label1
, code
);
9633 resolve_branch (code
->label2
, code
);
9634 resolve_branch (code
->label3
, code
);
9638 if (t
== SUCCESS
&& code
->expr1
!= NULL
9639 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9640 || code
->expr1
->rank
!= 0))
9641 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9642 &code
->expr1
->where
);
9647 resolve_call (code
);
9652 resolve_typebound_subroutine (code
);
9656 resolve_ppc_call (code
);
9660 /* Select is complicated. Also, a SELECT construct could be
9661 a transformed computed GOTO. */
9662 resolve_select (code
);
9665 case EXEC_SELECT_TYPE
:
9666 resolve_select_type (code
, ns
);
9670 resolve_block_construct (code
);
9674 if (code
->ext
.iterator
!= NULL
)
9676 gfc_iterator
*iter
= code
->ext
.iterator
;
9677 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9678 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9683 if (code
->expr1
== NULL
)
9684 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9686 && (code
->expr1
->rank
!= 0
9687 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9688 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9689 "a scalar LOGICAL expression", &code
->expr1
->where
);
9694 resolve_allocate_deallocate (code
, "ALLOCATE");
9698 case EXEC_DEALLOCATE
:
9700 resolve_allocate_deallocate (code
, "DEALLOCATE");
9705 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9708 resolve_branch (code
->ext
.open
->err
, code
);
9712 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9715 resolve_branch (code
->ext
.close
->err
, code
);
9718 case EXEC_BACKSPACE
:
9722 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9725 resolve_branch (code
->ext
.filepos
->err
, code
);
9729 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9732 resolve_branch (code
->ext
.inquire
->err
, code
);
9736 gcc_assert (code
->ext
.inquire
!= NULL
);
9737 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9740 resolve_branch (code
->ext
.inquire
->err
, code
);
9744 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9747 resolve_branch (code
->ext
.wait
->err
, code
);
9748 resolve_branch (code
->ext
.wait
->end
, code
);
9749 resolve_branch (code
->ext
.wait
->eor
, code
);
9754 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9757 resolve_branch (code
->ext
.dt
->err
, code
);
9758 resolve_branch (code
->ext
.dt
->end
, code
);
9759 resolve_branch (code
->ext
.dt
->eor
, code
);
9763 resolve_transfer (code
);
9766 case EXEC_DO_CONCURRENT
:
9768 resolve_forall_iterators (code
->ext
.forall_iterator
);
9770 if (code
->expr1
!= NULL
9771 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9772 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9773 "expression", &code
->expr1
->where
);
9776 case EXEC_OMP_ATOMIC
:
9777 case EXEC_OMP_BARRIER
:
9778 case EXEC_OMP_CRITICAL
:
9779 case EXEC_OMP_FLUSH
:
9781 case EXEC_OMP_MASTER
:
9782 case EXEC_OMP_ORDERED
:
9783 case EXEC_OMP_SECTIONS
:
9784 case EXEC_OMP_SINGLE
:
9785 case EXEC_OMP_TASKWAIT
:
9786 case EXEC_OMP_TASKYIELD
:
9787 case EXEC_OMP_WORKSHARE
:
9788 gfc_resolve_omp_directive (code
, ns
);
9791 case EXEC_OMP_PARALLEL
:
9792 case EXEC_OMP_PARALLEL_DO
:
9793 case EXEC_OMP_PARALLEL_SECTIONS
:
9794 case EXEC_OMP_PARALLEL_WORKSHARE
:
9796 omp_workshare_save
= omp_workshare_flag
;
9797 omp_workshare_flag
= 0;
9798 gfc_resolve_omp_directive (code
, ns
);
9799 omp_workshare_flag
= omp_workshare_save
;
9803 gfc_internal_error ("resolve_code(): Bad statement code");
9807 cs_base
= frame
.prev
;
9811 /* Resolve initial values and make sure they are compatible with
9815 resolve_values (gfc_symbol
*sym
)
9819 if (sym
->value
== NULL
)
9822 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9823 t
= resolve_structure_cons (sym
->value
, 1);
9825 t
= gfc_resolve_expr (sym
->value
);
9830 gfc_check_assign_symbol (sym
, sym
->value
);
9834 /* Verify the binding labels for common blocks that are BIND(C). The label
9835 for a BIND(C) common block must be identical in all scoping units in which
9836 the common block is declared. Further, the binding label can not collide
9837 with any other global entity in the program. */
9840 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9842 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9844 gfc_gsymbol
*binding_label_gsym
;
9845 gfc_gsymbol
*comm_name_gsym
;
9846 const char * bind_label
= comm_block_tree
->n
.common
->binding_label
9847 ? comm_block_tree
->n
.common
->binding_label
: "";
9849 /* See if a global symbol exists by the common block's name. It may
9850 be NULL if the common block is use-associated. */
9851 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9852 comm_block_tree
->n
.common
->name
);
9853 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9854 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9855 "with the global entity '%s' at %L",
9857 comm_block_tree
->n
.common
->name
,
9858 &(comm_block_tree
->n
.common
->where
),
9859 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9860 else if (comm_name_gsym
!= NULL
9861 && strcmp (comm_name_gsym
->name
,
9862 comm_block_tree
->n
.common
->name
) == 0)
9864 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9866 if (comm_name_gsym
->binding_label
== NULL
)
9867 /* No binding label for common block stored yet; save this one. */
9868 comm_name_gsym
->binding_label
= bind_label
;
9869 else if (strcmp (comm_name_gsym
->binding_label
, bind_label
) != 0)
9871 /* Common block names match but binding labels do not. */
9872 gfc_error ("Binding label '%s' for common block '%s' at %L "
9873 "does not match the binding label '%s' for common "
9876 comm_block_tree
->n
.common
->name
,
9877 &(comm_block_tree
->n
.common
->where
),
9878 comm_name_gsym
->binding_label
,
9879 comm_name_gsym
->name
,
9880 &(comm_name_gsym
->where
));
9885 /* There is no binding label (NAME="") so we have nothing further to
9886 check and nothing to add as a global symbol for the label. */
9887 if (!comm_block_tree
->n
.common
->binding_label
)
9890 binding_label_gsym
=
9891 gfc_find_gsymbol (gfc_gsym_root
,
9892 comm_block_tree
->n
.common
->binding_label
);
9893 if (binding_label_gsym
== NULL
)
9895 /* Need to make a global symbol for the binding label to prevent
9896 it from colliding with another. */
9897 binding_label_gsym
=
9898 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9899 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9900 binding_label_gsym
->type
= GSYM_COMMON
;
9904 /* If comm_name_gsym is NULL, the name common block is use
9905 associated and the name could be colliding. */
9906 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9907 gfc_error ("Binding label '%s' for common block '%s' at %L "
9908 "collides with the global entity '%s' at %L",
9909 comm_block_tree
->n
.common
->binding_label
,
9910 comm_block_tree
->n
.common
->name
,
9911 &(comm_block_tree
->n
.common
->where
),
9912 binding_label_gsym
->name
,
9913 &(binding_label_gsym
->where
));
9914 else if (comm_name_gsym
!= NULL
9915 && (strcmp (binding_label_gsym
->name
,
9916 comm_name_gsym
->binding_label
) != 0)
9917 && (strcmp (binding_label_gsym
->sym_name
,
9918 comm_name_gsym
->name
) != 0))
9919 gfc_error ("Binding label '%s' for common block '%s' at %L "
9920 "collides with global entity '%s' at %L",
9921 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9922 &(comm_block_tree
->n
.common
->where
),
9923 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9931 /* Verify any BIND(C) derived types in the namespace so we can report errors
9932 for them once, rather than for each variable declared of that type. */
9935 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9937 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9938 && derived_sym
->attr
.is_bind_c
== 1)
9939 verify_bind_c_derived_type (derived_sym
);
9945 /* Verify that any binding labels used in a given namespace do not collide
9946 with the names or binding labels of any global symbols. */
9949 gfc_verify_binding_labels (gfc_symbol
*sym
)
9953 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9954 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
)
9956 gfc_gsymbol
*bind_c_sym
;
9958 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9959 if (bind_c_sym
!= NULL
9960 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9962 if (sym
->attr
.if_source
== IFSRC_DECL
9963 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9964 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9965 && ((sym
->attr
.contained
== 1
9966 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9967 || (sym
->attr
.use_assoc
== 1
9968 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9970 /* Make sure global procedures don't collide with anything. */
9971 gfc_error ("Binding label '%s' at %L collides with the global "
9972 "entity '%s' at %L", sym
->binding_label
,
9973 &(sym
->declared_at
), bind_c_sym
->name
,
9974 &(bind_c_sym
->where
));
9977 else if (sym
->attr
.contained
== 0
9978 && (sym
->attr
.if_source
== IFSRC_IFBODY
9979 && sym
->attr
.flavor
== FL_PROCEDURE
)
9980 && (bind_c_sym
->sym_name
!= NULL
9981 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9983 /* Make sure procedures in interface bodies don't collide. */
9984 gfc_error ("Binding label '%s' in interface body at %L collides "
9985 "with the global entity '%s' at %L",
9987 &(sym
->declared_at
), bind_c_sym
->name
,
9988 &(bind_c_sym
->where
));
9991 else if (sym
->attr
.contained
== 0
9992 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9993 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9994 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9995 || sym
->attr
.use_assoc
== 0)
9997 gfc_error ("Binding label '%s' at %L collides with global "
9998 "entity '%s' at %L", sym
->binding_label
,
9999 &(sym
->declared_at
), bind_c_sym
->name
,
10000 &(bind_c_sym
->where
));
10004 if (has_error
!= 0)
10005 /* Clear the binding label to prevent checking multiple times. */
10006 sym
->binding_label
= NULL
;
10008 else if (bind_c_sym
== NULL
)
10010 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
10011 bind_c_sym
->where
= sym
->declared_at
;
10012 bind_c_sym
->sym_name
= sym
->name
;
10014 if (sym
->attr
.use_assoc
== 1)
10015 bind_c_sym
->mod_name
= sym
->module
;
10017 if (sym
->ns
->proc_name
!= NULL
)
10018 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
10020 if (sym
->attr
.contained
== 0)
10022 if (sym
->attr
.subroutine
)
10023 bind_c_sym
->type
= GSYM_SUBROUTINE
;
10024 else if (sym
->attr
.function
)
10025 bind_c_sym
->type
= GSYM_FUNCTION
;
10033 /* Resolve an index expression. */
10036 resolve_index_expr (gfc_expr
*e
)
10038 if (gfc_resolve_expr (e
) == FAILURE
)
10041 if (gfc_simplify_expr (e
, 0) == FAILURE
)
10044 if (gfc_specification_expr (e
) == FAILURE
)
10051 /* Resolve a charlen structure. */
10054 resolve_charlen (gfc_charlen
*cl
)
10064 if (cl
->length_from_typespec
)
10066 if (gfc_resolve_expr (cl
->length
) == FAILURE
)
10069 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
10074 specification_expr
= 1;
10076 if (resolve_index_expr (cl
->length
) == FAILURE
)
10078 specification_expr
= 0;
10083 /* "If the character length parameter value evaluates to a negative
10084 value, the length of character entities declared is zero." */
10085 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10087 if (gfc_option
.warn_surprising
)
10088 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10089 " the length has been set to zero",
10090 &cl
->length
->where
, i
);
10091 gfc_replace_expr (cl
->length
,
10092 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10095 /* Check that the character length is not too large. */
10096 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10097 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10098 && cl
->length
->ts
.type
== BT_INTEGER
10099 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10101 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10109 /* Test for non-constant shape arrays. */
10112 is_non_constant_shape_array (gfc_symbol
*sym
)
10118 not_constant
= false;
10119 if (sym
->as
!= NULL
)
10121 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10122 has not been simplified; parameter array references. Do the
10123 simplification now. */
10124 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10126 e
= sym
->as
->lower
[i
];
10127 if (e
&& (resolve_index_expr (e
) == FAILURE
10128 || !gfc_is_constant_expr (e
)))
10129 not_constant
= true;
10130 e
= sym
->as
->upper
[i
];
10131 if (e
&& (resolve_index_expr (e
) == FAILURE
10132 || !gfc_is_constant_expr (e
)))
10133 not_constant
= true;
10136 return not_constant
;
10139 /* Given a symbol and an initialization expression, add code to initialize
10140 the symbol to the function entry. */
10142 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10146 gfc_namespace
*ns
= sym
->ns
;
10148 /* Search for the function namespace if this is a contained
10149 function without an explicit result. */
10150 if (sym
->attr
.function
&& sym
== sym
->result
10151 && sym
->name
!= sym
->ns
->proc_name
->name
)
10153 ns
= ns
->contained
;
10154 for (;ns
; ns
= ns
->sibling
)
10155 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10161 gfc_free_expr (init
);
10165 /* Build an l-value expression for the result. */
10166 lval
= gfc_lval_expr_from_sym (sym
);
10168 /* Add the code at scope entry. */
10169 init_st
= gfc_get_code ();
10170 init_st
->next
= ns
->code
;
10171 ns
->code
= init_st
;
10173 /* Assign the default initializer to the l-value. */
10174 init_st
->loc
= sym
->declared_at
;
10175 init_st
->op
= EXEC_INIT_ASSIGN
;
10176 init_st
->expr1
= lval
;
10177 init_st
->expr2
= init
;
10180 /* Assign the default initializer to a derived type variable or result. */
10183 apply_default_init (gfc_symbol
*sym
)
10185 gfc_expr
*init
= NULL
;
10187 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10190 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10191 init
= gfc_default_initializer (&sym
->ts
);
10193 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10196 build_init_assign (sym
, init
);
10197 sym
->attr
.referenced
= 1;
10200 /* Build an initializer for a local integer, real, complex, logical, or
10201 character variable, based on the command line flags finit-local-zero,
10202 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10203 null if the symbol should not have a default initialization. */
10205 build_default_init_expr (gfc_symbol
*sym
)
10208 gfc_expr
*init_expr
;
10211 /* These symbols should never have a default initialization. */
10212 if (sym
->attr
.allocatable
10213 || sym
->attr
.external
10215 || sym
->attr
.pointer
10216 || sym
->attr
.in_equivalence
10217 || sym
->attr
.in_common
10220 || sym
->attr
.cray_pointee
10221 || sym
->attr
.cray_pointer
10225 /* Now we'll try to build an initializer expression. */
10226 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10227 &sym
->declared_at
);
10229 /* We will only initialize integers, reals, complex, logicals, and
10230 characters, and only if the corresponding command-line flags
10231 were set. Otherwise, we free init_expr and return null. */
10232 switch (sym
->ts
.type
)
10235 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10236 mpz_set_si (init_expr
->value
.integer
,
10237 gfc_option
.flag_init_integer_value
);
10240 gfc_free_expr (init_expr
);
10246 switch (gfc_option
.flag_init_real
)
10248 case GFC_INIT_REAL_SNAN
:
10249 init_expr
->is_snan
= 1;
10250 /* Fall through. */
10251 case GFC_INIT_REAL_NAN
:
10252 mpfr_set_nan (init_expr
->value
.real
);
10255 case GFC_INIT_REAL_INF
:
10256 mpfr_set_inf (init_expr
->value
.real
, 1);
10259 case GFC_INIT_REAL_NEG_INF
:
10260 mpfr_set_inf (init_expr
->value
.real
, -1);
10263 case GFC_INIT_REAL_ZERO
:
10264 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10268 gfc_free_expr (init_expr
);
10275 switch (gfc_option
.flag_init_real
)
10277 case GFC_INIT_REAL_SNAN
:
10278 init_expr
->is_snan
= 1;
10279 /* Fall through. */
10280 case GFC_INIT_REAL_NAN
:
10281 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10282 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10285 case GFC_INIT_REAL_INF
:
10286 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10287 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10290 case GFC_INIT_REAL_NEG_INF
:
10291 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10292 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10295 case GFC_INIT_REAL_ZERO
:
10296 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10300 gfc_free_expr (init_expr
);
10307 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10308 init_expr
->value
.logical
= 0;
10309 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10310 init_expr
->value
.logical
= 1;
10313 gfc_free_expr (init_expr
);
10319 /* For characters, the length must be constant in order to
10320 create a default initializer. */
10321 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10322 && sym
->ts
.u
.cl
->length
10323 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10325 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10326 init_expr
->value
.character
.length
= char_len
;
10327 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10328 for (i
= 0; i
< char_len
; i
++)
10329 init_expr
->value
.character
.string
[i
]
10330 = (unsigned char) gfc_option
.flag_init_character_value
;
10334 gfc_free_expr (init_expr
);
10337 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10338 && sym
->ts
.u
.cl
->length
)
10340 gfc_actual_arglist
*arg
;
10341 init_expr
= gfc_get_expr ();
10342 init_expr
->where
= sym
->declared_at
;
10343 init_expr
->ts
= sym
->ts
;
10344 init_expr
->expr_type
= EXPR_FUNCTION
;
10345 init_expr
->value
.function
.isym
=
10346 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10347 init_expr
->value
.function
.name
= "repeat";
10348 arg
= gfc_get_actual_arglist ();
10349 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10351 arg
->expr
->value
.character
.string
[0]
10352 = gfc_option
.flag_init_character_value
;
10353 arg
->next
= gfc_get_actual_arglist ();
10354 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10355 init_expr
->value
.function
.actual
= arg
;
10360 gfc_free_expr (init_expr
);
10366 /* Add an initialization expression to a local variable. */
10368 apply_default_init_local (gfc_symbol
*sym
)
10370 gfc_expr
*init
= NULL
;
10372 /* The symbol should be a variable or a function return value. */
10373 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10374 || (sym
->attr
.function
&& sym
->result
!= sym
))
10377 /* Try to build the initializer expression. If we can't initialize
10378 this symbol, then init will be NULL. */
10379 init
= build_default_init_expr (sym
);
10383 /* For saved variables, we don't want to add an initializer at function
10384 entry, so we just add a static initializer. Note that automatic variables
10385 are stack allocated even with -fno-automatic. */
10386 if (sym
->attr
.save
|| sym
->ns
->save_all
10387 || (gfc_option
.flag_max_stack_var_size
== 0
10388 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10390 /* Don't clobber an existing initializer! */
10391 gcc_assert (sym
->value
== NULL
);
10396 build_init_assign (sym
, init
);
10400 /* Resolution of common features of flavors variable and procedure. */
10403 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10405 gfc_array_spec
*as
;
10407 /* Avoid double diagnostics for function result symbols. */
10408 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10409 && (sym
->ns
!= gfc_current_ns
))
10412 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10413 as
= CLASS_DATA (sym
)->as
;
10417 /* Constraints on deferred shape variable. */
10418 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10420 bool pointer
, allocatable
, dimension
;
10422 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10424 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10425 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10426 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10430 pointer
= sym
->attr
.pointer
;
10431 allocatable
= sym
->attr
.allocatable
;
10432 dimension
= sym
->attr
.dimension
;
10437 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10439 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10440 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10443 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10444 "'%s' at %L may not be ALLOCATABLE",
10445 sym
->name
, &sym
->declared_at
) == FAILURE
)
10449 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10451 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10452 "assumed rank", sym
->name
, &sym
->declared_at
);
10458 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10459 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10461 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10462 sym
->name
, &sym
->declared_at
);
10467 /* Constraints on polymorphic variables. */
10468 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10471 if (sym
->attr
.class_ok
10472 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10474 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10475 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10476 &sym
->declared_at
);
10481 /* Assume that use associated symbols were checked in the module ns.
10482 Class-variables that are associate-names are also something special
10483 and excepted from the test. */
10484 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10486 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10487 "or pointer", sym
->name
, &sym
->declared_at
);
10496 /* Additional checks for symbols with flavor variable and derived
10497 type. To be called from resolve_fl_variable. */
10500 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10502 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10504 /* Check to see if a derived type is blocked from being host
10505 associated by the presence of another class I symbol in the same
10506 namespace. 14.6.1.3 of the standard and the discussion on
10507 comp.lang.fortran. */
10508 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10509 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10512 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10513 if (s
&& s
->attr
.generic
)
10514 s
= gfc_find_dt_in_generic (s
);
10515 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10517 gfc_error ("The type '%s' cannot be host associated at %L "
10518 "because it is blocked by an incompatible object "
10519 "of the same name declared at %L",
10520 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10526 /* 4th constraint in section 11.3: "If an object of a type for which
10527 component-initialization is specified (R429) appears in the
10528 specification-part of a module and does not have the ALLOCATABLE
10529 or POINTER attribute, the object shall have the SAVE attribute."
10531 The check for initializers is performed with
10532 gfc_has_default_initializer because gfc_default_initializer generates
10533 a hidden default for allocatable components. */
10534 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10535 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10536 && !sym
->ns
->save_all
&& !sym
->attr
.save
10537 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10538 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10539 && gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for "
10540 "module variable '%s' at %L, needed due to "
10541 "the default initialization", sym
->name
,
10542 &sym
->declared_at
) == FAILURE
)
10545 /* Assign default initializer. */
10546 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10547 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10549 sym
->value
= gfc_default_initializer (&sym
->ts
);
10556 /* Resolve symbols with flavor variable. */
10559 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10561 int no_init_flag
, automatic_flag
;
10563 const char *auto_save_msg
;
10565 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10568 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10571 /* Set this flag to check that variables are parameters of all entries.
10572 This check is effected by the call to gfc_resolve_expr through
10573 is_non_constant_shape_array. */
10574 specification_expr
= 1;
10576 if (sym
->ns
->proc_name
10577 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10578 || sym
->ns
->proc_name
->attr
.is_main_program
)
10579 && !sym
->attr
.use_assoc
10580 && !sym
->attr
.allocatable
10581 && !sym
->attr
.pointer
10582 && is_non_constant_shape_array (sym
))
10584 /* The shape of a main program or module array needs to be
10586 gfc_error ("The module or main program array '%s' at %L must "
10587 "have constant shape", sym
->name
, &sym
->declared_at
);
10588 specification_expr
= 0;
10592 /* Constraints on deferred type parameter. */
10593 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10595 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10596 "requires either the pointer or allocatable attribute",
10597 sym
->name
, &sym
->declared_at
);
10601 if (sym
->ts
.type
== BT_CHARACTER
)
10603 /* Make sure that character string variables with assumed length are
10604 dummy arguments. */
10605 e
= sym
->ts
.u
.cl
->length
;
10606 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10607 && !sym
->ts
.deferred
)
10609 gfc_error ("Entity with assumed character length at %L must be a "
10610 "dummy argument or a PARAMETER", &sym
->declared_at
);
10614 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10616 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10620 if (!gfc_is_constant_expr (e
)
10621 && !(e
->expr_type
== EXPR_VARIABLE
10622 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10624 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10625 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10626 || sym
->ns
->proc_name
->attr
.is_main_program
))
10628 gfc_error ("'%s' at %L must have constant character length "
10629 "in this context", sym
->name
, &sym
->declared_at
);
10632 if (sym
->attr
.in_common
)
10634 gfc_error ("COMMON variable '%s' at %L must have constant "
10635 "character length", sym
->name
, &sym
->declared_at
);
10641 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10642 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10644 /* Determine if the symbol may not have an initializer. */
10645 no_init_flag
= automatic_flag
= 0;
10646 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10647 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10649 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10650 && is_non_constant_shape_array (sym
))
10652 no_init_flag
= automatic_flag
= 1;
10654 /* Also, they must not have the SAVE attribute.
10655 SAVE_IMPLICIT is checked below. */
10656 if (sym
->as
&& sym
->attr
.codimension
)
10658 int corank
= sym
->as
->corank
;
10659 sym
->as
->corank
= 0;
10660 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10661 sym
->as
->corank
= corank
;
10663 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10665 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10670 /* Ensure that any initializer is simplified. */
10672 gfc_simplify_expr (sym
->value
, 1);
10674 /* Reject illegal initializers. */
10675 if (!sym
->mark
&& sym
->value
)
10677 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10678 && CLASS_DATA (sym
)->attr
.allocatable
))
10679 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10680 sym
->name
, &sym
->declared_at
);
10681 else if (sym
->attr
.external
)
10682 gfc_error ("External '%s' at %L cannot have an initializer",
10683 sym
->name
, &sym
->declared_at
);
10684 else if (sym
->attr
.dummy
10685 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10686 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10687 sym
->name
, &sym
->declared_at
);
10688 else if (sym
->attr
.intrinsic
)
10689 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10690 sym
->name
, &sym
->declared_at
);
10691 else if (sym
->attr
.result
)
10692 gfc_error ("Function result '%s' at %L cannot have an initializer",
10693 sym
->name
, &sym
->declared_at
);
10694 else if (automatic_flag
)
10695 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10696 sym
->name
, &sym
->declared_at
);
10698 goto no_init_error
;
10703 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10704 return resolve_fl_variable_derived (sym
, no_init_flag
);
10710 /* Resolve a procedure. */
10713 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10715 gfc_formal_arglist
*arg
;
10717 if (sym
->attr
.function
10718 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10721 if (sym
->ts
.type
== BT_CHARACTER
)
10723 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10725 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10726 && resolve_charlen (cl
) == FAILURE
)
10729 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10730 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10732 gfc_error ("Character-valued statement function '%s' at %L must "
10733 "have constant length", sym
->name
, &sym
->declared_at
);
10738 /* Ensure that derived type for are not of a private type. Internal
10739 module procedures are excluded by 2.2.3.3 - i.e., they are not
10740 externally accessible and can access all the objects accessible in
10742 if (!(sym
->ns
->parent
10743 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10744 && gfc_check_symbol_access (sym
))
10746 gfc_interface
*iface
;
10748 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10751 && arg
->sym
->ts
.type
== BT_DERIVED
10752 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10753 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10754 && gfc_notify_std (GFC_STD_F2003
, "'%s' is of a "
10755 "PRIVATE type and cannot be a dummy argument"
10756 " of '%s', which is PUBLIC at %L",
10757 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10760 /* Stop this message from recurring. */
10761 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10766 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10767 PRIVATE to the containing module. */
10768 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10770 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10773 && arg
->sym
->ts
.type
== BT_DERIVED
10774 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10775 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10776 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
10777 "'%s' in PUBLIC interface '%s' at %L "
10778 "takes dummy arguments of '%s' which is "
10779 "PRIVATE", iface
->sym
->name
, sym
->name
,
10780 &iface
->sym
->declared_at
,
10781 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10783 /* Stop this message from recurring. */
10784 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10790 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10791 PRIVATE to the containing module. */
10792 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10794 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10797 && arg
->sym
->ts
.type
== BT_DERIVED
10798 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10799 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10800 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
10801 "'%s' in PUBLIC interface '%s' at %L "
10802 "takes dummy arguments of '%s' which is "
10803 "PRIVATE", iface
->sym
->name
, sym
->name
,
10804 &iface
->sym
->declared_at
,
10805 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10807 /* Stop this message from recurring. */
10808 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10815 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10816 && !sym
->attr
.proc_pointer
)
10818 gfc_error ("Function '%s' at %L cannot have an initializer",
10819 sym
->name
, &sym
->declared_at
);
10823 /* An external symbol may not have an initializer because it is taken to be
10824 a procedure. Exception: Procedure Pointers. */
10825 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10827 gfc_error ("External object '%s' at %L may not have an initializer",
10828 sym
->name
, &sym
->declared_at
);
10832 /* An elemental function is required to return a scalar 12.7.1 */
10833 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10835 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10836 "result", sym
->name
, &sym
->declared_at
);
10837 /* Reset so that the error only occurs once. */
10838 sym
->attr
.elemental
= 0;
10842 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10843 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10845 gfc_error ("Statement function '%s' at %L may not have pointer or "
10846 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10850 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10851 char-len-param shall not be array-valued, pointer-valued, recursive
10852 or pure. ....snip... A character value of * may only be used in the
10853 following ways: (i) Dummy arg of procedure - dummy associates with
10854 actual length; (ii) To declare a named constant; or (iii) External
10855 function - but length must be declared in calling scoping unit. */
10856 if (sym
->attr
.function
10857 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
10858 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10860 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10861 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10863 if (sym
->as
&& sym
->as
->rank
)
10864 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10865 "array-valued", sym
->name
, &sym
->declared_at
);
10867 if (sym
->attr
.pointer
)
10868 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10869 "pointer-valued", sym
->name
, &sym
->declared_at
);
10871 if (sym
->attr
.pure
)
10872 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10873 "pure", sym
->name
, &sym
->declared_at
);
10875 if (sym
->attr
.recursive
)
10876 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10877 "recursive", sym
->name
, &sym
->declared_at
);
10882 /* Appendix B.2 of the standard. Contained functions give an
10883 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10884 character length is an F2003 feature. */
10885 if (!sym
->attr
.contained
10886 && gfc_current_form
!= FORM_FIXED
10887 && !sym
->ts
.deferred
)
10888 gfc_notify_std (GFC_STD_F95_OBS
,
10889 "CHARACTER(*) function '%s' at %L",
10890 sym
->name
, &sym
->declared_at
);
10893 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10895 gfc_formal_arglist
*curr_arg
;
10896 int has_non_interop_arg
= 0;
10898 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10899 sym
->common_block
) == FAILURE
)
10901 /* Clear these to prevent looking at them again if there was an
10903 sym
->attr
.is_bind_c
= 0;
10904 sym
->attr
.is_c_interop
= 0;
10905 sym
->ts
.is_c_interop
= 0;
10909 /* So far, no errors have been found. */
10910 sym
->attr
.is_c_interop
= 1;
10911 sym
->ts
.is_c_interop
= 1;
10914 curr_arg
= sym
->formal
;
10915 while (curr_arg
!= NULL
)
10917 /* Skip implicitly typed dummy args here. */
10918 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10919 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10920 /* If something is found to fail, record the fact so we
10921 can mark the symbol for the procedure as not being
10922 BIND(C) to try and prevent multiple errors being
10924 has_non_interop_arg
= 1;
10926 curr_arg
= curr_arg
->next
;
10929 /* See if any of the arguments were not interoperable and if so, clear
10930 the procedure symbol to prevent duplicate error messages. */
10931 if (has_non_interop_arg
!= 0)
10933 sym
->attr
.is_c_interop
= 0;
10934 sym
->ts
.is_c_interop
= 0;
10935 sym
->attr
.is_bind_c
= 0;
10939 if (!sym
->attr
.proc_pointer
)
10941 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10943 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10944 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10947 if (sym
->attr
.intent
)
10949 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10950 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10953 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10955 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10956 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10959 if (sym
->attr
.external
&& sym
->attr
.function
10960 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10961 || sym
->attr
.contained
))
10963 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10964 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10967 if (strcmp ("ppr@", sym
->name
) == 0)
10969 gfc_error ("Procedure pointer result '%s' at %L "
10970 "is missing the pointer attribute",
10971 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10980 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10981 been defined and we now know their defined arguments, check that they fulfill
10982 the requirements of the standard for procedures used as finalizers. */
10985 gfc_resolve_finalizers (gfc_symbol
* derived
)
10987 gfc_finalizer
* list
;
10988 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10989 gfc_try result
= SUCCESS
;
10990 bool seen_scalar
= false;
10992 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10995 /* Walk over the list of finalizer-procedures, check them, and if any one
10996 does not fit in with the standard's definition, print an error and remove
10997 it from the list. */
10998 prev_link
= &derived
->f2k_derived
->finalizers
;
10999 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11005 /* Skip this finalizer if we already resolved it. */
11006 if (list
->proc_tree
)
11008 prev_link
= &(list
->next
);
11012 /* Check this exists and is a SUBROUTINE. */
11013 if (!list
->proc_sym
->attr
.subroutine
)
11015 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11016 list
->proc_sym
->name
, &list
->where
);
11020 /* We should have exactly one argument. */
11021 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
11023 gfc_error ("FINAL procedure at %L must have exactly one argument",
11027 arg
= list
->proc_sym
->formal
->sym
;
11029 /* This argument must be of our type. */
11030 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11032 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11033 &arg
->declared_at
, derived
->name
);
11037 /* It must neither be a pointer nor allocatable nor optional. */
11038 if (arg
->attr
.pointer
)
11040 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11041 &arg
->declared_at
);
11044 if (arg
->attr
.allocatable
)
11046 gfc_error ("Argument of FINAL procedure at %L must not be"
11047 " ALLOCATABLE", &arg
->declared_at
);
11050 if (arg
->attr
.optional
)
11052 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11053 &arg
->declared_at
);
11057 /* It must not be INTENT(OUT). */
11058 if (arg
->attr
.intent
== INTENT_OUT
)
11060 gfc_error ("Argument of FINAL procedure at %L must not be"
11061 " INTENT(OUT)", &arg
->declared_at
);
11065 /* Warn if the procedure is non-scalar and not assumed shape. */
11066 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11067 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11068 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11069 " shape argument", &arg
->declared_at
);
11071 /* Check that it does not match in kind and rank with a FINAL procedure
11072 defined earlier. To really loop over the *earlier* declarations,
11073 we need to walk the tail of the list as new ones were pushed at the
11075 /* TODO: Handle kind parameters once they are implemented. */
11076 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11077 for (i
= list
->next
; i
; i
= i
->next
)
11079 /* Argument list might be empty; that is an error signalled earlier,
11080 but we nevertheless continued resolving. */
11081 if (i
->proc_sym
->formal
)
11083 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
11084 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11085 if (i_rank
== my_rank
)
11087 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11088 " rank (%d) as '%s'",
11089 list
->proc_sym
->name
, &list
->where
, my_rank
,
11090 i
->proc_sym
->name
);
11096 /* Is this the/a scalar finalizer procedure? */
11097 if (!arg
->as
|| arg
->as
->rank
== 0)
11098 seen_scalar
= true;
11100 /* Find the symtree for this procedure. */
11101 gcc_assert (!list
->proc_tree
);
11102 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11104 prev_link
= &list
->next
;
11107 /* Remove wrong nodes immediately from the list so we don't risk any
11108 troubles in the future when they might fail later expectations. */
11112 *prev_link
= list
->next
;
11113 gfc_free_finalizer (i
);
11116 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11117 were nodes in the list, must have been for arrays. It is surely a good
11118 idea to have a scalar version there if there's something to finalize. */
11119 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
11120 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11121 " defined at %L, suggest also scalar one",
11122 derived
->name
, &derived
->declared_at
);
11124 /* TODO: Remove this error when finalization is finished. */
11125 gfc_error ("Finalization at %L is not yet implemented",
11126 &derived
->declared_at
);
11132 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11135 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11136 const char* generic_name
, locus where
)
11138 gfc_symbol
*sym1
, *sym2
;
11139 const char *pass1
, *pass2
;
11141 gcc_assert (t1
->specific
&& t2
->specific
);
11142 gcc_assert (!t1
->specific
->is_generic
);
11143 gcc_assert (!t2
->specific
->is_generic
);
11144 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11146 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11147 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11152 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11153 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11154 || sym1
->attr
.function
!= sym2
->attr
.function
)
11156 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11157 " GENERIC '%s' at %L",
11158 sym1
->name
, sym2
->name
, generic_name
, &where
);
11162 /* Compare the interfaces. */
11163 if (t1
->specific
->nopass
)
11165 else if (t1
->specific
->pass_arg
)
11166 pass1
= t1
->specific
->pass_arg
;
11168 pass1
= t1
->specific
->u
.specific
->n
.sym
->formal
->sym
->name
;
11169 if (t2
->specific
->nopass
)
11171 else if (t2
->specific
->pass_arg
)
11172 pass2
= t2
->specific
->pass_arg
;
11174 pass2
= t2
->specific
->u
.specific
->n
.sym
->formal
->sym
->name
;
11175 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11176 NULL
, 0, pass1
, pass2
))
11178 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11179 sym1
->name
, sym2
->name
, generic_name
, &where
);
11187 /* Worker function for resolving a generic procedure binding; this is used to
11188 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11190 The difference between those cases is finding possible inherited bindings
11191 that are overridden, as one has to look for them in tb_sym_root,
11192 tb_uop_root or tb_op, respectively. Thus the caller must already find
11193 the super-type and set p->overridden correctly. */
11196 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11197 gfc_typebound_proc
* p
, const char* name
)
11199 gfc_tbp_generic
* target
;
11200 gfc_symtree
* first_target
;
11201 gfc_symtree
* inherited
;
11203 gcc_assert (p
&& p
->is_generic
);
11205 /* Try to find the specific bindings for the symtrees in our target-list. */
11206 gcc_assert (p
->u
.generic
);
11207 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11208 if (!target
->specific
)
11210 gfc_typebound_proc
* overridden_tbp
;
11211 gfc_tbp_generic
* g
;
11212 const char* target_name
;
11214 target_name
= target
->specific_st
->name
;
11216 /* Defined for this type directly. */
11217 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11219 target
->specific
= target
->specific_st
->n
.tb
;
11220 goto specific_found
;
11223 /* Look for an inherited specific binding. */
11226 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11231 gcc_assert (inherited
->n
.tb
);
11232 target
->specific
= inherited
->n
.tb
;
11233 goto specific_found
;
11237 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11238 " at %L", target_name
, name
, &p
->where
);
11241 /* Once we've found the specific binding, check it is not ambiguous with
11242 other specifics already found or inherited for the same GENERIC. */
11244 gcc_assert (target
->specific
);
11246 /* This must really be a specific binding! */
11247 if (target
->specific
->is_generic
)
11249 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11250 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11254 /* Check those already resolved on this type directly. */
11255 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11256 if (g
!= target
&& g
->specific
11257 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11261 /* Check for ambiguity with inherited specific targets. */
11262 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11263 overridden_tbp
= overridden_tbp
->overridden
)
11264 if (overridden_tbp
->is_generic
)
11266 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11268 gcc_assert (g
->specific
);
11269 if (check_generic_tbp_ambiguity (target
, g
,
11270 name
, p
->where
) == FAILURE
)
11276 /* If we attempt to "overwrite" a specific binding, this is an error. */
11277 if (p
->overridden
&& !p
->overridden
->is_generic
)
11279 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11280 " the same name", name
, &p
->where
);
11284 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11285 all must have the same attributes here. */
11286 first_target
= p
->u
.generic
->specific
->u
.specific
;
11287 gcc_assert (first_target
);
11288 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11289 p
->function
= first_target
->n
.sym
->attr
.function
;
11295 /* Resolve a GENERIC procedure binding for a derived type. */
11298 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11300 gfc_symbol
* super_type
;
11302 /* Find the overridden binding if any. */
11303 st
->n
.tb
->overridden
= NULL
;
11304 super_type
= gfc_get_derived_super_type (derived
);
11307 gfc_symtree
* overridden
;
11308 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11311 if (overridden
&& overridden
->n
.tb
)
11312 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11315 /* Resolve using worker function. */
11316 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11320 /* Retrieve the target-procedure of an operator binding and do some checks in
11321 common for intrinsic and user-defined type-bound operators. */
11324 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11326 gfc_symbol
* target_proc
;
11328 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11329 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11330 gcc_assert (target_proc
);
11332 /* All operator bindings must have a passed-object dummy argument. */
11333 if (target
->specific
->nopass
)
11335 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11339 return target_proc
;
11343 /* Resolve a type-bound intrinsic operator. */
11346 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11347 gfc_typebound_proc
* p
)
11349 gfc_symbol
* super_type
;
11350 gfc_tbp_generic
* target
;
11352 /* If there's already an error here, do nothing (but don't fail again). */
11356 /* Operators should always be GENERIC bindings. */
11357 gcc_assert (p
->is_generic
);
11359 /* Look for an overridden binding. */
11360 super_type
= gfc_get_derived_super_type (derived
);
11361 if (super_type
&& super_type
->f2k_derived
)
11362 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11365 p
->overridden
= NULL
;
11367 /* Resolve general GENERIC properties using worker function. */
11368 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11371 /* Check the targets to be procedures of correct interface. */
11372 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11374 gfc_symbol
* target_proc
;
11376 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11380 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11383 /* Add target to non-typebound operator list. */
11384 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11385 && p
->access
!= ACCESS_PRIVATE
)
11387 gfc_interface
*head
, *intr
;
11388 if (gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
,
11389 p
->where
) == FAILURE
)
11391 head
= derived
->ns
->op
[op
];
11392 intr
= gfc_get_interface ();
11393 intr
->sym
= target_proc
;
11394 intr
->where
= p
->where
;
11396 derived
->ns
->op
[op
] = intr
;
11408 /* Resolve a type-bound user operator (tree-walker callback). */
11410 static gfc_symbol
* resolve_bindings_derived
;
11411 static gfc_try resolve_bindings_result
;
11413 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11416 resolve_typebound_user_op (gfc_symtree
* stree
)
11418 gfc_symbol
* super_type
;
11419 gfc_tbp_generic
* target
;
11421 gcc_assert (stree
&& stree
->n
.tb
);
11423 if (stree
->n
.tb
->error
)
11426 /* Operators should always be GENERIC bindings. */
11427 gcc_assert (stree
->n
.tb
->is_generic
);
11429 /* Find overridden procedure, if any. */
11430 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11431 if (super_type
&& super_type
->f2k_derived
)
11433 gfc_symtree
* overridden
;
11434 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11435 stree
->name
, true, NULL
);
11437 if (overridden
&& overridden
->n
.tb
)
11438 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11441 stree
->n
.tb
->overridden
= NULL
;
11443 /* Resolve basically using worker function. */
11444 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11448 /* Check the targets to be functions of correct interface. */
11449 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11451 gfc_symbol
* target_proc
;
11453 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11457 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11464 resolve_bindings_result
= FAILURE
;
11465 stree
->n
.tb
->error
= 1;
11469 /* Resolve the type-bound procedures for a derived type. */
11472 resolve_typebound_procedure (gfc_symtree
* stree
)
11476 gfc_symbol
* me_arg
;
11477 gfc_symbol
* super_type
;
11478 gfc_component
* comp
;
11480 gcc_assert (stree
);
11482 /* Undefined specific symbol from GENERIC target definition. */
11486 if (stree
->n
.tb
->error
)
11489 /* If this is a GENERIC binding, use that routine. */
11490 if (stree
->n
.tb
->is_generic
)
11492 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11498 /* Get the target-procedure to check it. */
11499 gcc_assert (!stree
->n
.tb
->is_generic
);
11500 gcc_assert (stree
->n
.tb
->u
.specific
);
11501 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11502 where
= stree
->n
.tb
->where
;
11503 proc
->attr
.public_used
= 1;
11505 /* Default access should already be resolved from the parser. */
11506 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11508 /* It should be a module procedure or an external procedure with explicit
11509 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11510 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11511 || (proc
->attr
.proc
!= PROC_MODULE
11512 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11513 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11515 gfc_error ("'%s' must be a module procedure or an external procedure with"
11516 " an explicit interface at %L", proc
->name
, &where
);
11519 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11520 stree
->n
.tb
->function
= proc
->attr
.function
;
11522 /* Find the super-type of the current derived type. We could do this once and
11523 store in a global if speed is needed, but as long as not I believe this is
11524 more readable and clearer. */
11525 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11527 /* If PASS, resolve and check arguments if not already resolved / loaded
11528 from a .mod file. */
11529 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11531 if (stree
->n
.tb
->pass_arg
)
11533 gfc_formal_arglist
* i
;
11535 /* If an explicit passing argument name is given, walk the arg-list
11536 and look for it. */
11539 stree
->n
.tb
->pass_arg_num
= 1;
11540 for (i
= proc
->formal
; i
; i
= i
->next
)
11542 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11547 ++stree
->n
.tb
->pass_arg_num
;
11552 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11554 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11555 stree
->n
.tb
->pass_arg
);
11561 /* Otherwise, take the first one; there should in fact be at least
11563 stree
->n
.tb
->pass_arg_num
= 1;
11566 gfc_error ("Procedure '%s' with PASS at %L must have at"
11567 " least one argument", proc
->name
, &where
);
11570 me_arg
= proc
->formal
->sym
;
11573 /* Now check that the argument-type matches and the passed-object
11574 dummy argument is generally fine. */
11576 gcc_assert (me_arg
);
11578 if (me_arg
->ts
.type
!= BT_CLASS
)
11580 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11581 " at %L", proc
->name
, &where
);
11585 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11586 != resolve_bindings_derived
)
11588 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11589 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11590 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11594 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11595 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11597 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11598 " scalar", proc
->name
, &where
);
11601 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11603 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11604 " be ALLOCATABLE", proc
->name
, &where
);
11607 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11609 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11610 " be POINTER", proc
->name
, &where
);
11615 /* If we are extending some type, check that we don't override a procedure
11616 flagged NON_OVERRIDABLE. */
11617 stree
->n
.tb
->overridden
= NULL
;
11620 gfc_symtree
* overridden
;
11621 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11622 stree
->name
, true, NULL
);
11626 if (overridden
->n
.tb
)
11627 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11629 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11634 /* See if there's a name collision with a component directly in this type. */
11635 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11636 if (!strcmp (comp
->name
, stree
->name
))
11638 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11640 stree
->name
, &where
, resolve_bindings_derived
->name
);
11644 /* Try to find a name collision with an inherited component. */
11645 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11647 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11648 " component of '%s'",
11649 stree
->name
, &where
, resolve_bindings_derived
->name
);
11653 stree
->n
.tb
->error
= 0;
11657 resolve_bindings_result
= FAILURE
;
11658 stree
->n
.tb
->error
= 1;
11663 resolve_typebound_procedures (gfc_symbol
* derived
)
11666 gfc_symbol
* super_type
;
11668 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11671 super_type
= gfc_get_derived_super_type (derived
);
11673 resolve_typebound_procedures (super_type
);
11675 resolve_bindings_derived
= derived
;
11676 resolve_bindings_result
= SUCCESS
;
11678 /* Make sure the vtab has been generated. */
11679 gfc_find_derived_vtab (derived
);
11681 if (derived
->f2k_derived
->tb_sym_root
)
11682 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11683 &resolve_typebound_procedure
);
11685 if (derived
->f2k_derived
->tb_uop_root
)
11686 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11687 &resolve_typebound_user_op
);
11689 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11691 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11692 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11694 resolve_bindings_result
= FAILURE
;
11697 return resolve_bindings_result
;
11701 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11702 to give all identical derived types the same backend_decl. */
11704 add_dt_to_dt_list (gfc_symbol
*derived
)
11706 gfc_dt_list
*dt_list
;
11708 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11709 if (derived
== dt_list
->derived
)
11712 dt_list
= gfc_get_dt_list ();
11713 dt_list
->next
= gfc_derived_types
;
11714 dt_list
->derived
= derived
;
11715 gfc_derived_types
= dt_list
;
11719 /* Ensure that a derived-type is really not abstract, meaning that every
11720 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11723 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11728 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11730 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11733 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11735 gfc_symtree
* overriding
;
11736 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11739 gcc_assert (overriding
->n
.tb
);
11740 if (overriding
->n
.tb
->deferred
)
11742 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11743 " '%s' is DEFERRED and not overridden",
11744 sub
->name
, &sub
->declared_at
, st
->name
);
11753 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11755 /* The algorithm used here is to recursively travel up the ancestry of sub
11756 and for each ancestor-type, check all bindings. If any of them is
11757 DEFERRED, look it up starting from sub and see if the found (overriding)
11758 binding is not DEFERRED.
11759 This is not the most efficient way to do this, but it should be ok and is
11760 clearer than something sophisticated. */
11762 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11764 if (!ancestor
->attr
.abstract
)
11767 /* Walk bindings of this ancestor. */
11768 if (ancestor
->f2k_derived
)
11771 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11776 /* Find next ancestor type and recurse on it. */
11777 ancestor
= gfc_get_derived_super_type (ancestor
);
11779 return ensure_not_abstract (sub
, ancestor
);
11785 /* Resolve the components of a derived type. This does not have to wait until
11786 resolution stage, but can be done as soon as the dt declaration has been
11790 resolve_fl_derived0 (gfc_symbol
*sym
)
11792 gfc_symbol
* super_type
;
11795 super_type
= gfc_get_derived_super_type (sym
);
11798 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11800 gfc_error ("As extending type '%s' at %L has a coarray component, "
11801 "parent type '%s' shall also have one", sym
->name
,
11802 &sym
->declared_at
, super_type
->name
);
11806 /* Ensure the extended type gets resolved before we do. */
11807 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11810 /* An ABSTRACT type must be extensible. */
11811 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11813 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11814 sym
->name
, &sym
->declared_at
);
11818 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11821 for ( ; c
!= NULL
; c
= c
->next
)
11823 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11824 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
11826 gfc_error ("Deferred-length character component '%s' at %L is not "
11827 "yet supported", c
->name
, &c
->loc
);
11832 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
11833 && c
->attr
.codimension
11834 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11836 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11837 "deferred shape", c
->name
, &c
->loc
);
11842 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11843 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11845 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11846 "shall not be a coarray", c
->name
, &c
->loc
);
11851 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11852 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11853 || c
->attr
.allocatable
))
11855 gfc_error ("Component '%s' at %L with coarray component "
11856 "shall be a nonpointer, nonallocatable scalar",
11862 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11864 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11865 "is not an array pointer", c
->name
, &c
->loc
);
11869 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11871 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11872 gfc_error ("Interface '%s', used by procedure pointer component "
11873 "'%s' at %L, is declared in a later PROCEDURE statement",
11874 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11876 /* Get the attributes from the interface (now resolved). */
11877 if (c
->ts
.interface
->attr
.if_source
11878 || c
->ts
.interface
->attr
.intrinsic
)
11880 gfc_symbol
*ifc
= c
->ts
.interface
;
11882 if (ifc
->formal
&& !ifc
->formal_ns
)
11883 resolve_symbol (ifc
);
11885 if (ifc
->attr
.intrinsic
)
11886 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11890 c
->ts
= ifc
->result
->ts
;
11891 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11892 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11893 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11894 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11899 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11900 c
->attr
.pointer
= ifc
->attr
.pointer
;
11901 c
->attr
.dimension
= ifc
->attr
.dimension
;
11902 c
->as
= gfc_copy_array_spec (ifc
->as
);
11904 c
->ts
.interface
= ifc
;
11905 c
->attr
.function
= ifc
->attr
.function
;
11906 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11907 gfc_copy_formal_args_ppc (c
, ifc
, IFSRC_DECL
);
11909 c
->attr
.pure
= ifc
->attr
.pure
;
11910 c
->attr
.elemental
= ifc
->attr
.elemental
;
11911 c
->attr
.recursive
= ifc
->attr
.recursive
;
11912 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11913 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11914 /* Replace symbols in array spec. */
11918 for (i
= 0; i
< c
->as
->rank
; i
++)
11920 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11921 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11924 /* Copy char length. */
11925 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11927 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11928 gfc_expr_replace_comp (cl
->length
, c
);
11929 if (cl
->length
&& !cl
->resolved
11930 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11935 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11937 gfc_error ("Interface '%s' of procedure pointer component "
11938 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11943 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11945 /* Since PPCs are not implicitly typed, a PPC without an explicit
11946 interface must be a subroutine. */
11947 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11950 /* Procedure pointer components: Check PASS arg. */
11951 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11952 && !sym
->attr
.vtype
)
11954 gfc_symbol
* me_arg
;
11956 if (c
->tb
->pass_arg
)
11958 gfc_formal_arglist
* i
;
11960 /* If an explicit passing argument name is given, walk the arg-list
11961 and look for it. */
11964 c
->tb
->pass_arg_num
= 1;
11965 for (i
= c
->formal
; i
; i
= i
->next
)
11967 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11972 c
->tb
->pass_arg_num
++;
11977 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11978 "at %L has no argument '%s'", c
->name
,
11979 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11986 /* Otherwise, take the first one; there should in fact be at least
11988 c
->tb
->pass_arg_num
= 1;
11991 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11992 "must have at least one argument",
11997 me_arg
= c
->formal
->sym
;
12000 /* Now check that the argument-type matches. */
12001 gcc_assert (me_arg
);
12002 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12003 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12004 || (me_arg
->ts
.type
== BT_CLASS
12005 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12007 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12008 " the derived type '%s'", me_arg
->name
, c
->name
,
12009 me_arg
->name
, &c
->loc
, sym
->name
);
12014 /* Check for C453. */
12015 if (me_arg
->attr
.dimension
)
12017 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12018 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12024 if (me_arg
->attr
.pointer
)
12026 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12027 "may not have the POINTER attribute", me_arg
->name
,
12028 c
->name
, me_arg
->name
, &c
->loc
);
12033 if (me_arg
->attr
.allocatable
)
12035 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12036 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12037 me_arg
->name
, &c
->loc
);
12042 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12043 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12044 " at %L", c
->name
, &c
->loc
);
12048 /* Check type-spec if this is not the parent-type component. */
12049 if (((sym
->attr
.is_class
12050 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12051 || c
!= sym
->components
->ts
.u
.derived
->components
))
12052 || (!sym
->attr
.is_class
12053 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12054 && !sym
->attr
.vtype
12055 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
12058 /* If this type is an extension, set the accessibility of the parent
12061 && ((sym
->attr
.is_class
12062 && c
== sym
->components
->ts
.u
.derived
->components
)
12063 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12064 && strcmp (super_type
->name
, c
->name
) == 0)
12065 c
->attr
.access
= super_type
->attr
.access
;
12067 /* If this type is an extension, see if this component has the same name
12068 as an inherited type-bound procedure. */
12069 if (super_type
&& !sym
->attr
.is_class
12070 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12072 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12073 " inherited type-bound procedure",
12074 c
->name
, sym
->name
, &c
->loc
);
12078 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12079 && !c
->ts
.deferred
)
12081 if (c
->ts
.u
.cl
->length
== NULL
12082 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
12083 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12085 gfc_error ("Character length of component '%s' needs to "
12086 "be a constant specification expression at %L",
12088 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12093 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12094 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12096 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12097 "length must be a POINTER or ALLOCATABLE",
12098 c
->name
, sym
->name
, &c
->loc
);
12102 if (c
->ts
.type
== BT_DERIVED
12103 && sym
->component_access
!= ACCESS_PRIVATE
12104 && gfc_check_symbol_access (sym
)
12105 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12106 && !c
->ts
.u
.derived
->attr
.use_assoc
12107 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12108 && gfc_notify_std (GFC_STD_F2003
, "the component '%s' "
12109 "is a PRIVATE type and cannot be a component of "
12110 "'%s', which is PUBLIC at %L", c
->name
,
12111 sym
->name
, &sym
->declared_at
) == FAILURE
)
12114 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12116 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12117 "type %s", c
->name
, &c
->loc
, sym
->name
);
12121 if (sym
->attr
.sequence
)
12123 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12125 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12126 "not have the SEQUENCE attribute",
12127 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12132 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12133 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12134 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12135 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12136 CLASS_DATA (c
)->ts
.u
.derived
12137 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12139 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12140 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12141 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12143 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12144 "that has not been declared", c
->name
, sym
->name
,
12149 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12150 && CLASS_DATA (c
)->attr
.class_pointer
12151 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12152 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
12154 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12155 "that has not been declared", c
->name
, sym
->name
,
12161 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12162 && (!c
->attr
.class_ok
12163 || !(CLASS_DATA (c
)->attr
.class_pointer
12164 || CLASS_DATA (c
)->attr
.allocatable
)))
12166 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12167 "or pointer", c
->name
, &c
->loc
);
12171 /* Ensure that all the derived type components are put on the
12172 derived type list; even in formal namespaces, where derived type
12173 pointer components might not have been declared. */
12174 if (c
->ts
.type
== BT_DERIVED
12176 && c
->ts
.u
.derived
->components
12178 && sym
!= c
->ts
.u
.derived
)
12179 add_dt_to_dt_list (c
->ts
.u
.derived
);
12181 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
12182 || c
->attr
.proc_pointer
12183 || c
->attr
.allocatable
)) == FAILURE
)
12187 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12188 all DEFERRED bindings are overridden. */
12189 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12190 && !sym
->attr
.is_class
12191 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
12194 /* Add derived type to the derived type list. */
12195 add_dt_to_dt_list (sym
);
12201 /* The following procedure does the full resolution of a derived type,
12202 including resolution of all type-bound procedures (if present). In contrast
12203 to 'resolve_fl_derived0' this can only be done after the module has been
12204 parsed completely. */
12207 resolve_fl_derived (gfc_symbol
*sym
)
12209 gfc_symbol
*gen_dt
= NULL
;
12211 if (!sym
->attr
.is_class
)
12212 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12213 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12214 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12215 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12216 && gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of "
12217 "function '%s' at %L being the same name as derived "
12218 "type at %L", sym
->name
,
12219 gen_dt
->generic
->sym
== sym
12220 ? gen_dt
->generic
->next
->sym
->name
12221 : gen_dt
->generic
->sym
->name
,
12222 gen_dt
->generic
->sym
== sym
12223 ? &gen_dt
->generic
->next
->sym
->declared_at
12224 : &gen_dt
->generic
->sym
->declared_at
,
12225 &sym
->declared_at
) == FAILURE
)
12228 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12230 /* Fix up incomplete CLASS symbols. */
12231 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12232 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12233 if (vptr
->ts
.u
.derived
== NULL
)
12235 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12237 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12241 if (resolve_fl_derived0 (sym
) == FAILURE
)
12244 /* Resolve the type-bound procedures. */
12245 if (resolve_typebound_procedures (sym
) == FAILURE
)
12248 /* Resolve the finalizer procedures. */
12249 if (gfc_resolve_finalizers (sym
) == FAILURE
)
12257 resolve_fl_namelist (gfc_symbol
*sym
)
12262 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12264 /* Check again, the check in match only works if NAMELIST comes
12266 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12268 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12269 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12273 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12274 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
12275 "object '%s' with assumed shape in namelist "
12276 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12277 &sym
->declared_at
) == FAILURE
)
12280 if (is_non_constant_shape_array (nl
->sym
)
12281 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
12282 "object '%s' with nonconstant shape in namelist "
12283 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12284 &sym
->declared_at
) == FAILURE
)
12287 if (nl
->sym
->ts
.type
== BT_CHARACTER
12288 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12289 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12290 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
12291 "'%s' with nonconstant character length in "
12292 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
12293 &sym
->declared_at
) == FAILURE
)
12296 /* FIXME: Once UDDTIO is implemented, the following can be
12298 if (nl
->sym
->ts
.type
== BT_CLASS
)
12300 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12301 "polymorphic and requires a defined input/output "
12302 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12306 if (nl
->sym
->ts
.type
== BT_DERIVED
12307 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12308 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12310 if (gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
12311 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12312 "or POINTER components", nl
->sym
->name
,
12313 sym
->name
, &sym
->declared_at
) == FAILURE
)
12316 /* FIXME: Once UDDTIO is implemented, the following can be
12318 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12319 "ALLOCATABLE or POINTER components and thus requires "
12320 "a defined input/output procedure", nl
->sym
->name
,
12321 sym
->name
, &sym
->declared_at
);
12326 /* Reject PRIVATE objects in a PUBLIC namelist. */
12327 if (gfc_check_symbol_access (sym
))
12329 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12331 if (!nl
->sym
->attr
.use_assoc
12332 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12333 && !gfc_check_symbol_access (nl
->sym
))
12335 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12336 "cannot be member of PUBLIC namelist '%s' at %L",
12337 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12341 /* Types with private components that came here by USE-association. */
12342 if (nl
->sym
->ts
.type
== BT_DERIVED
12343 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12345 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12346 "components and cannot be member of namelist '%s' at %L",
12347 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12351 /* Types with private components that are defined in the same module. */
12352 if (nl
->sym
->ts
.type
== BT_DERIVED
12353 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12354 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12356 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12357 "cannot be a member of PUBLIC namelist '%s' at %L",
12358 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12365 /* 14.1.2 A module or internal procedure represent local entities
12366 of the same type as a namelist member and so are not allowed. */
12367 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12369 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12372 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12373 if ((nl
->sym
== sym
->ns
->proc_name
)
12375 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12379 if (nl
->sym
&& nl
->sym
->name
)
12380 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12381 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12383 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12384 "attribute in '%s' at %L", nlsym
->name
,
12385 &sym
->declared_at
);
12395 resolve_fl_parameter (gfc_symbol
*sym
)
12397 /* A parameter array's shape needs to be constant. */
12398 if (sym
->as
!= NULL
12399 && (sym
->as
->type
== AS_DEFERRED
12400 || is_non_constant_shape_array (sym
)))
12402 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12403 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12407 /* Make sure a parameter that has been implicitly typed still
12408 matches the implicit type, since PARAMETER statements can precede
12409 IMPLICIT statements. */
12410 if (sym
->attr
.implicit_type
12411 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12414 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12415 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12419 /* Make sure the types of derived parameters are consistent. This
12420 type checking is deferred until resolution because the type may
12421 refer to a derived type from the host. */
12422 if (sym
->ts
.type
== BT_DERIVED
12423 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12425 gfc_error ("Incompatible derived type in PARAMETER at %L",
12426 &sym
->value
->where
);
12433 /* Do anything necessary to resolve a symbol. Right now, we just
12434 assume that an otherwise unknown symbol is a variable. This sort
12435 of thing commonly happens for symbols in module. */
12438 resolve_symbol (gfc_symbol
*sym
)
12440 int check_constant
, mp_flag
;
12441 gfc_symtree
*symtree
;
12442 gfc_symtree
*this_symtree
;
12445 symbol_attribute class_attr
;
12446 gfc_array_spec
*as
;
12448 if (sym
->attr
.flavor
== FL_UNKNOWN
12449 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12450 && !sym
->attr
.generic
&& !sym
->attr
.external
12451 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12454 /* If we find that a flavorless symbol is an interface in one of the
12455 parent namespaces, find its symtree in this namespace, free the
12456 symbol and set the symtree to point to the interface symbol. */
12457 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12459 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12460 if (symtree
&& (symtree
->n
.sym
->generic
||
12461 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12462 && sym
->ns
->construct_entities
)))
12464 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12466 gfc_release_symbol (sym
);
12467 symtree
->n
.sym
->refs
++;
12468 this_symtree
->n
.sym
= symtree
->n
.sym
;
12473 /* Otherwise give it a flavor according to such attributes as
12475 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12476 && sym
->attr
.intrinsic
== 0)
12477 sym
->attr
.flavor
= FL_VARIABLE
;
12478 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12480 sym
->attr
.flavor
= FL_PROCEDURE
;
12481 if (sym
->attr
.dimension
)
12482 sym
->attr
.function
= 1;
12486 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12487 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12489 if (sym
->attr
.procedure
&& sym
->ts
.interface
12490 && sym
->attr
.if_source
!= IFSRC_DECL
12491 && resolve_procedure_interface (sym
) == FAILURE
)
12494 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12495 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12497 if (sym
->attr
.external
)
12498 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12499 "at %L", &sym
->declared_at
);
12501 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12502 "at %L", &sym
->declared_at
);
12507 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12510 /* Symbols that are module procedures with results (functions) have
12511 the types and array specification copied for type checking in
12512 procedures that call them, as well as for saving to a module
12513 file. These symbols can't stand the scrutiny that their results
12515 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12517 /* Make sure that the intrinsic is consistent with its internal
12518 representation. This needs to be done before assigning a default
12519 type to avoid spurious warnings. */
12520 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12521 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12524 /* Resolve associate names. */
12526 resolve_assoc_var (sym
, true);
12528 /* Assign default type to symbols that need one and don't have one. */
12529 if (sym
->ts
.type
== BT_UNKNOWN
)
12531 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12533 gfc_set_default_type (sym
, 1, NULL
);
12536 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12537 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12538 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12539 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12541 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12543 /* The specific case of an external procedure should emit an error
12544 in the case that there is no implicit type. */
12546 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12549 /* Result may be in another namespace. */
12550 resolve_symbol (sym
->result
);
12552 if (!sym
->result
->attr
.proc_pointer
)
12554 sym
->ts
= sym
->result
->ts
;
12555 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12556 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12557 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12558 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12559 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12564 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12565 gfc_resolve_array_spec (sym
->result
->as
, false);
12567 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12569 as
= CLASS_DATA (sym
)->as
;
12570 class_attr
= CLASS_DATA (sym
)->attr
;
12571 class_attr
.pointer
= class_attr
.class_pointer
;
12575 class_attr
= sym
->attr
;
12580 if (sym
->attr
.contiguous
12581 && (!class_attr
.dimension
12582 || (as
->type
!= AS_ASSUMED_SHAPE
&& !class_attr
.pointer
)))
12584 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12585 "array pointer or an assumed-shape array", sym
->name
,
12586 &sym
->declared_at
);
12590 /* Assumed size arrays and assumed shape arrays must be dummy
12591 arguments. Array-spec's of implied-shape should have been resolved to
12592 AS_EXPLICIT already. */
12596 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12597 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12598 || as
->type
== AS_ASSUMED_SHAPE
)
12599 && sym
->attr
.dummy
== 0)
12601 if (as
->type
== AS_ASSUMED_SIZE
)
12602 gfc_error ("Assumed size array at %L must be a dummy argument",
12603 &sym
->declared_at
);
12605 gfc_error ("Assumed shape array at %L must be a dummy argument",
12606 &sym
->declared_at
);
12609 /* TS 29113, C535a. */
12610 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
)
12612 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12613 &sym
->declared_at
);
12616 if (as
->type
== AS_ASSUMED_RANK
12617 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12619 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12620 "CODIMENSION attribute", &sym
->declared_at
);
12625 /* Make sure symbols with known intent or optional are really dummy
12626 variable. Because of ENTRY statement, this has to be deferred
12627 until resolution time. */
12629 if (!sym
->attr
.dummy
12630 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12632 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12636 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12638 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12639 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12643 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12645 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12646 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12648 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12649 "attribute must have constant length",
12650 sym
->name
, &sym
->declared_at
);
12654 if (sym
->ts
.is_c_interop
12655 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12657 gfc_error ("C interoperable character dummy variable '%s' at %L "
12658 "with VALUE attribute must have length one",
12659 sym
->name
, &sym
->declared_at
);
12664 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12665 && sym
->ts
.u
.derived
->attr
.generic
)
12667 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12668 if (!sym
->ts
.u
.derived
)
12670 gfc_error ("The derived type '%s' at %L is of type '%s', "
12671 "which has not been defined", sym
->name
,
12672 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12673 sym
->ts
.type
= BT_UNKNOWN
;
12678 if (sym
->ts
.type
== BT_ASSUMED
)
12680 /* TS 29113, C407a. */
12681 if (!sym
->attr
.dummy
)
12683 gfc_error ("Assumed type of variable %s at %L is only permitted "
12684 "for dummy variables", sym
->name
, &sym
->declared_at
);
12687 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12688 || sym
->attr
.pointer
|| sym
->attr
.value
)
12690 gfc_error ("Assumed-type variable %s at %L may not have the "
12691 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12692 sym
->name
, &sym
->declared_at
);
12695 if (sym
->attr
.intent
== INTENT_OUT
)
12697 gfc_error ("Assumed-type variable %s at %L may not have the "
12698 "INTENT(OUT) attribute",
12699 sym
->name
, &sym
->declared_at
);
12702 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12704 gfc_error ("Assumed-type variable %s at %L shall not be an "
12705 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12710 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12711 do this for something that was implicitly typed because that is handled
12712 in gfc_set_default_type. Handle dummy arguments and procedure
12713 definitions separately. Also, anything that is use associated is not
12714 handled here but instead is handled in the module it is declared in.
12715 Finally, derived type definitions are allowed to be BIND(C) since that
12716 only implies that they're interoperable, and they are checked fully for
12717 interoperability when a variable is declared of that type. */
12718 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12719 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12720 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12722 gfc_try t
= SUCCESS
;
12724 /* First, make sure the variable is declared at the
12725 module-level scope (J3/04-007, Section 15.3). */
12726 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12727 sym
->attr
.in_common
== 0)
12729 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12730 "is neither a COMMON block nor declared at the "
12731 "module level scope", sym
->name
, &(sym
->declared_at
));
12734 else if (sym
->common_head
!= NULL
)
12736 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12740 /* If type() declaration, we need to verify that the components
12741 of the given type are all C interoperable, etc. */
12742 if (sym
->ts
.type
== BT_DERIVED
&&
12743 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12745 /* Make sure the user marked the derived type as BIND(C). If
12746 not, call the verify routine. This could print an error
12747 for the derived type more than once if multiple variables
12748 of that type are declared. */
12749 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12750 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12754 /* Verify the variable itself as C interoperable if it
12755 is BIND(C). It is not possible for this to succeed if
12756 the verify_bind_c_derived_type failed, so don't have to handle
12757 any error returned by verify_bind_c_derived_type. */
12758 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12759 sym
->common_block
);
12764 /* clear the is_bind_c flag to prevent reporting errors more than
12765 once if something failed. */
12766 sym
->attr
.is_bind_c
= 0;
12771 /* If a derived type symbol has reached this point, without its
12772 type being declared, we have an error. Notice that most
12773 conditions that produce undefined derived types have already
12774 been dealt with. However, the likes of:
12775 implicit type(t) (t) ..... call foo (t) will get us here if
12776 the type is not declared in the scope of the implicit
12777 statement. Change the type to BT_UNKNOWN, both because it is so
12778 and to prevent an ICE. */
12779 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12780 && sym
->ts
.u
.derived
->components
== NULL
12781 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12783 gfc_error ("The derived type '%s' at %L is of type '%s', "
12784 "which has not been defined", sym
->name
,
12785 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12786 sym
->ts
.type
= BT_UNKNOWN
;
12790 /* Make sure that the derived type has been resolved and that the
12791 derived type is visible in the symbol's namespace, if it is a
12792 module function and is not PRIVATE. */
12793 if (sym
->ts
.type
== BT_DERIVED
12794 && sym
->ts
.u
.derived
->attr
.use_assoc
12795 && sym
->ns
->proc_name
12796 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12797 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12800 /* Unless the derived-type declaration is use associated, Fortran 95
12801 does not allow public entries of private derived types.
12802 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12803 161 in 95-006r3. */
12804 if (sym
->ts
.type
== BT_DERIVED
12805 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12806 && !sym
->ts
.u
.derived
->attr
.use_assoc
12807 && gfc_check_symbol_access (sym
)
12808 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12809 && gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L "
12810 "of PRIVATE derived type '%s'",
12811 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12812 : "variable", sym
->name
, &sym
->declared_at
,
12813 sym
->ts
.u
.derived
->name
) == FAILURE
)
12816 /* F2008, C1302. */
12817 if (sym
->ts
.type
== BT_DERIVED
12818 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12819 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12820 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12821 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12823 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12824 "type LOCK_TYPE must be a coarray", sym
->name
,
12825 &sym
->declared_at
);
12829 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12830 default initialization is defined (5.1.2.4.4). */
12831 if (sym
->ts
.type
== BT_DERIVED
12833 && sym
->attr
.intent
== INTENT_OUT
12835 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12837 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12839 if (c
->initializer
)
12841 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12842 "ASSUMED SIZE and so cannot have a default initializer",
12843 sym
->name
, &sym
->declared_at
);
12850 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12851 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12853 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12854 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12859 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12860 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12861 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12862 || class_attr
.codimension
)
12863 && (sym
->attr
.result
|| sym
->result
== sym
))
12865 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12866 "a coarray component", sym
->name
, &sym
->declared_at
);
12871 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12872 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12874 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12875 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12880 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12881 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12882 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12883 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
12884 || class_attr
.allocatable
))
12886 gfc_error ("Variable '%s' at %L with coarray component "
12887 "shall be a nonpointer, nonallocatable scalar",
12888 sym
->name
, &sym
->declared_at
);
12892 /* F2008, C526. The function-result case was handled above. */
12893 if (class_attr
.codimension
12894 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12895 || sym
->attr
.select_type_temporary
12896 || sym
->ns
->save_all
12897 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12898 || sym
->ns
->proc_name
->attr
.is_main_program
12899 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12901 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
12902 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
12906 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
12907 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
12909 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12910 "deferred shape", sym
->name
, &sym
->declared_at
);
12913 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
12914 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
12916 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12917 "deferred shape", sym
->name
, &sym
->declared_at
);
12922 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12923 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12924 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12925 || (class_attr
.codimension
&& class_attr
.allocatable
))
12926 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12928 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12929 "allocatable coarray or have coarray components",
12930 sym
->name
, &sym
->declared_at
);
12934 if (class_attr
.codimension
&& sym
->attr
.dummy
12935 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12937 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12938 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12939 sym
->ns
->proc_name
->name
);
12943 switch (sym
->attr
.flavor
)
12946 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12951 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12956 if (resolve_fl_namelist (sym
) == FAILURE
)
12961 if (resolve_fl_parameter (sym
) == FAILURE
)
12969 /* Resolve array specifier. Check as well some constraints
12970 on COMMON blocks. */
12972 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12974 /* Set the formal_arg_flag so that check_conflict will not throw
12975 an error for host associated variables in the specification
12976 expression for an array_valued function. */
12977 if (sym
->attr
.function
&& sym
->as
)
12978 formal_arg_flag
= 1;
12980 gfc_resolve_array_spec (sym
->as
, check_constant
);
12982 formal_arg_flag
= 0;
12984 /* Resolve formal namespaces. */
12985 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12986 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12987 gfc_resolve (sym
->formal_ns
);
12989 /* Make sure the formal namespace is present. */
12990 if (sym
->formal
&& !sym
->formal_ns
)
12992 gfc_formal_arglist
*formal
= sym
->formal
;
12993 while (formal
&& !formal
->sym
)
12994 formal
= formal
->next
;
12998 sym
->formal_ns
= formal
->sym
->ns
;
12999 sym
->formal_ns
->refs
++;
13003 /* Check threadprivate restrictions. */
13004 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13005 && (!sym
->attr
.in_common
13006 && sym
->module
== NULL
13007 && (sym
->ns
->proc_name
== NULL
13008 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13009 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13011 /* If we have come this far we can apply default-initializers, as
13012 described in 14.7.5, to those variables that have not already
13013 been assigned one. */
13014 if (sym
->ts
.type
== BT_DERIVED
13015 && sym
->ns
== gfc_current_ns
13017 && !sym
->attr
.allocatable
13018 && !sym
->attr
.alloc_comp
)
13020 symbol_attribute
*a
= &sym
->attr
;
13022 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13023 && !a
->in_common
&& !a
->use_assoc
13024 && (a
->referenced
|| a
->result
)
13025 && !(a
->function
&& sym
!= sym
->result
))
13026 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13027 apply_default_init (sym
);
13030 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13031 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13032 && !CLASS_DATA (sym
)->attr
.class_pointer
13033 && !CLASS_DATA (sym
)->attr
.allocatable
)
13034 apply_default_init (sym
);
13036 /* If this symbol has a type-spec, check it. */
13037 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13038 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13039 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
13045 /************* Resolve DATA statements *************/
13049 gfc_data_value
*vnode
;
13055 /* Advance the values structure to point to the next value in the data list. */
13058 next_data_value (void)
13060 while (mpz_cmp_ui (values
.left
, 0) == 0)
13063 if (values
.vnode
->next
== NULL
)
13066 values
.vnode
= values
.vnode
->next
;
13067 mpz_set (values
.left
, values
.vnode
->repeat
);
13075 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13081 ar_type mark
= AR_UNKNOWN
;
13083 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13089 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
13093 mpz_init_set_si (offset
, 0);
13096 if (e
->expr_type
!= EXPR_VARIABLE
)
13097 gfc_internal_error ("check_data_variable(): Bad expression");
13099 sym
= e
->symtree
->n
.sym
;
13101 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13103 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13104 sym
->name
, &sym
->declared_at
);
13107 if (e
->ref
== NULL
&& sym
->as
)
13109 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13110 " declaration", sym
->name
, where
);
13114 has_pointer
= sym
->attr
.pointer
;
13116 if (gfc_is_coindexed (e
))
13118 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13123 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13125 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13129 && ref
->type
== REF_ARRAY
13130 && ref
->u
.ar
.type
!= AR_FULL
)
13132 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13133 "be a full array", sym
->name
, where
);
13138 if (e
->rank
== 0 || has_pointer
)
13140 mpz_init_set_ui (size
, 1);
13147 /* Find the array section reference. */
13148 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13150 if (ref
->type
!= REF_ARRAY
)
13152 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13158 /* Set marks according to the reference pattern. */
13159 switch (ref
->u
.ar
.type
)
13167 /* Get the start position of array section. */
13168 gfc_get_section_index (ar
, section_index
, &offset
);
13173 gcc_unreachable ();
13176 if (gfc_array_size (e
, &size
) == FAILURE
)
13178 gfc_error ("Nonconstant array section at %L in DATA statement",
13180 mpz_clear (offset
);
13187 while (mpz_cmp_ui (size
, 0) > 0)
13189 if (next_data_value () == FAILURE
)
13191 gfc_error ("DATA statement at %L has more variables than values",
13197 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13201 /* If we have more than one element left in the repeat count,
13202 and we have more than one element left in the target variable,
13203 then create a range assignment. */
13204 /* FIXME: Only done for full arrays for now, since array sections
13206 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13207 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13211 if (mpz_cmp (size
, values
.left
) >= 0)
13213 mpz_init_set (range
, values
.left
);
13214 mpz_sub (size
, size
, values
.left
);
13215 mpz_set_ui (values
.left
, 0);
13219 mpz_init_set (range
, size
);
13220 mpz_sub (values
.left
, values
.left
, size
);
13221 mpz_set_ui (size
, 0);
13224 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13227 mpz_add (offset
, offset
, range
);
13234 /* Assign initial value to symbol. */
13237 mpz_sub_ui (values
.left
, values
.left
, 1);
13238 mpz_sub_ui (size
, size
, 1);
13240 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13245 if (mark
== AR_FULL
)
13246 mpz_add_ui (offset
, offset
, 1);
13248 /* Modify the array section indexes and recalculate the offset
13249 for next element. */
13250 else if (mark
== AR_SECTION
)
13251 gfc_advance_section (section_index
, ar
, &offset
);
13255 if (mark
== AR_SECTION
)
13257 for (i
= 0; i
< ar
->dimen
; i
++)
13258 mpz_clear (section_index
[i
]);
13262 mpz_clear (offset
);
13268 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
13270 /* Iterate over a list of elements in a DATA statement. */
13273 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13276 iterator_stack frame
;
13277 gfc_expr
*e
, *start
, *end
, *step
;
13278 gfc_try retval
= SUCCESS
;
13280 mpz_init (frame
.value
);
13283 start
= gfc_copy_expr (var
->iter
.start
);
13284 end
= gfc_copy_expr (var
->iter
.end
);
13285 step
= gfc_copy_expr (var
->iter
.step
);
13287 if (gfc_simplify_expr (start
, 1) == FAILURE
13288 || start
->expr_type
!= EXPR_CONSTANT
)
13290 gfc_error ("start of implied-do loop at %L could not be "
13291 "simplified to a constant value", &start
->where
);
13295 if (gfc_simplify_expr (end
, 1) == FAILURE
13296 || end
->expr_type
!= EXPR_CONSTANT
)
13298 gfc_error ("end of implied-do loop at %L could not be "
13299 "simplified to a constant value", &start
->where
);
13303 if (gfc_simplify_expr (step
, 1) == FAILURE
13304 || step
->expr_type
!= EXPR_CONSTANT
)
13306 gfc_error ("step of implied-do loop at %L could not be "
13307 "simplified to a constant value", &start
->where
);
13312 mpz_set (trip
, end
->value
.integer
);
13313 mpz_sub (trip
, trip
, start
->value
.integer
);
13314 mpz_add (trip
, trip
, step
->value
.integer
);
13316 mpz_div (trip
, trip
, step
->value
.integer
);
13318 mpz_set (frame
.value
, start
->value
.integer
);
13320 frame
.prev
= iter_stack
;
13321 frame
.variable
= var
->iter
.var
->symtree
;
13322 iter_stack
= &frame
;
13324 while (mpz_cmp_ui (trip
, 0) > 0)
13326 if (traverse_data_var (var
->list
, where
) == FAILURE
)
13332 e
= gfc_copy_expr (var
->expr
);
13333 if (gfc_simplify_expr (e
, 1) == FAILURE
)
13340 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13342 mpz_sub_ui (trip
, trip
, 1);
13346 mpz_clear (frame
.value
);
13349 gfc_free_expr (start
);
13350 gfc_free_expr (end
);
13351 gfc_free_expr (step
);
13353 iter_stack
= frame
.prev
;
13358 /* Type resolve variables in the variable list of a DATA statement. */
13361 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13365 for (; var
; var
= var
->next
)
13367 if (var
->expr
== NULL
)
13368 t
= traverse_data_list (var
, where
);
13370 t
= check_data_variable (var
, where
);
13380 /* Resolve the expressions and iterators associated with a data statement.
13381 This is separate from the assignment checking because data lists should
13382 only be resolved once. */
13385 resolve_data_variables (gfc_data_variable
*d
)
13387 for (; d
; d
= d
->next
)
13389 if (d
->list
== NULL
)
13391 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
13396 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
13399 if (resolve_data_variables (d
->list
) == FAILURE
)
13408 /* Resolve a single DATA statement. We implement this by storing a pointer to
13409 the value list into static variables, and then recursively traversing the
13410 variables list, expanding iterators and such. */
13413 resolve_data (gfc_data
*d
)
13416 if (resolve_data_variables (d
->var
) == FAILURE
)
13419 values
.vnode
= d
->value
;
13420 if (d
->value
== NULL
)
13421 mpz_set_ui (values
.left
, 0);
13423 mpz_set (values
.left
, d
->value
->repeat
);
13425 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13428 /* At this point, we better not have any values left. */
13430 if (next_data_value () == SUCCESS
)
13431 gfc_error ("DATA statement at %L has more values than variables",
13436 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13437 accessed by host or use association, is a dummy argument to a pure function,
13438 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13439 is storage associated with any such variable, shall not be used in the
13440 following contexts: (clients of this function). */
13442 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13443 procedure. Returns zero if assignment is OK, nonzero if there is a
13446 gfc_impure_variable (gfc_symbol
*sym
)
13451 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13454 /* Check if the symbol's ns is inside the pure procedure. */
13455 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13459 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13463 proc
= sym
->ns
->proc_name
;
13464 if (sym
->attr
.dummy
&& gfc_pure (proc
)
13465 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13467 proc
->attr
.function
))
13470 /* TODO: Sort out what can be storage associated, if anything, and include
13471 it here. In principle equivalences should be scanned but it does not
13472 seem to be possible to storage associate an impure variable this way. */
13477 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13478 current namespace is inside a pure procedure. */
13481 gfc_pure (gfc_symbol
*sym
)
13483 symbol_attribute attr
;
13488 /* Check if the current namespace or one of its parents
13489 belongs to a pure procedure. */
13490 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13492 sym
= ns
->proc_name
;
13496 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13504 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13508 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13509 checks if the current namespace is implicitly pure. Note that this
13510 function returns false for a PURE procedure. */
13513 gfc_implicit_pure (gfc_symbol
*sym
)
13519 /* Check if the current procedure is implicit_pure. Walk up
13520 the procedure list until we find a procedure. */
13521 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13523 sym
= ns
->proc_name
;
13527 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13532 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13533 && !sym
->attr
.pure
;
13537 /* Test whether the current procedure is elemental or not. */
13540 gfc_elemental (gfc_symbol
*sym
)
13542 symbol_attribute attr
;
13545 sym
= gfc_current_ns
->proc_name
;
13550 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13554 /* Warn about unused labels. */
13557 warn_unused_fortran_label (gfc_st_label
*label
)
13562 warn_unused_fortran_label (label
->left
);
13564 if (label
->defined
== ST_LABEL_UNKNOWN
)
13567 switch (label
->referenced
)
13569 case ST_LABEL_UNKNOWN
:
13570 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13574 case ST_LABEL_BAD_TARGET
:
13575 gfc_warning ("Label %d at %L defined but cannot be used",
13576 label
->value
, &label
->where
);
13583 warn_unused_fortran_label (label
->right
);
13587 /* Returns the sequence type of a symbol or sequence. */
13590 sequence_type (gfc_typespec ts
)
13599 if (ts
.u
.derived
->components
== NULL
)
13600 return SEQ_NONDEFAULT
;
13602 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13603 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13604 if (sequence_type (c
->ts
) != result
)
13610 if (ts
.kind
!= gfc_default_character_kind
)
13611 return SEQ_NONDEFAULT
;
13613 return SEQ_CHARACTER
;
13616 if (ts
.kind
!= gfc_default_integer_kind
)
13617 return SEQ_NONDEFAULT
;
13619 return SEQ_NUMERIC
;
13622 if (!(ts
.kind
== gfc_default_real_kind
13623 || ts
.kind
== gfc_default_double_kind
))
13624 return SEQ_NONDEFAULT
;
13626 return SEQ_NUMERIC
;
13629 if (ts
.kind
!= gfc_default_complex_kind
)
13630 return SEQ_NONDEFAULT
;
13632 return SEQ_NUMERIC
;
13635 if (ts
.kind
!= gfc_default_logical_kind
)
13636 return SEQ_NONDEFAULT
;
13638 return SEQ_NUMERIC
;
13641 return SEQ_NONDEFAULT
;
13646 /* Resolve derived type EQUIVALENCE object. */
13649 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13651 gfc_component
*c
= derived
->components
;
13656 /* Shall not be an object of nonsequence derived type. */
13657 if (!derived
->attr
.sequence
)
13659 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13660 "attribute to be an EQUIVALENCE object", sym
->name
,
13665 /* Shall not have allocatable components. */
13666 if (derived
->attr
.alloc_comp
)
13668 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13669 "components to be an EQUIVALENCE object",sym
->name
,
13674 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13676 gfc_error ("Derived type variable '%s' at %L with default "
13677 "initialization cannot be in EQUIVALENCE with a variable "
13678 "in COMMON", sym
->name
, &e
->where
);
13682 for (; c
; c
= c
->next
)
13684 if (c
->ts
.type
== BT_DERIVED
13685 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13688 /* Shall not be an object of sequence derived type containing a pointer
13689 in the structure. */
13690 if (c
->attr
.pointer
)
13692 gfc_error ("Derived type variable '%s' at %L with pointer "
13693 "component(s) cannot be an EQUIVALENCE object",
13694 sym
->name
, &e
->where
);
13702 /* Resolve equivalence object.
13703 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13704 an allocatable array, an object of nonsequence derived type, an object of
13705 sequence derived type containing a pointer at any level of component
13706 selection, an automatic object, a function name, an entry name, a result
13707 name, a named constant, a structure component, or a subobject of any of
13708 the preceding objects. A substring shall not have length zero. A
13709 derived type shall not have components with default initialization nor
13710 shall two objects of an equivalence group be initialized.
13711 Either all or none of the objects shall have an protected attribute.
13712 The simple constraints are done in symbol.c(check_conflict) and the rest
13713 are implemented here. */
13716 resolve_equivalence (gfc_equiv
*eq
)
13719 gfc_symbol
*first_sym
;
13722 locus
*last_where
= NULL
;
13723 seq_type eq_type
, last_eq_type
;
13724 gfc_typespec
*last_ts
;
13725 int object
, cnt_protected
;
13728 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13730 first_sym
= eq
->expr
->symtree
->n
.sym
;
13734 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13738 e
->ts
= e
->symtree
->n
.sym
->ts
;
13739 /* match_varspec might not know yet if it is seeing
13740 array reference or substring reference, as it doesn't
13742 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13744 gfc_ref
*ref
= e
->ref
;
13745 sym
= e
->symtree
->n
.sym
;
13747 if (sym
->attr
.dimension
)
13749 ref
->u
.ar
.as
= sym
->as
;
13753 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13754 if (e
->ts
.type
== BT_CHARACTER
13756 && ref
->type
== REF_ARRAY
13757 && ref
->u
.ar
.dimen
== 1
13758 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13759 && ref
->u
.ar
.stride
[0] == NULL
)
13761 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13762 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13765 /* Optimize away the (:) reference. */
13766 if (start
== NULL
&& end
== NULL
)
13769 e
->ref
= ref
->next
;
13771 e
->ref
->next
= ref
->next
;
13776 ref
->type
= REF_SUBSTRING
;
13778 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13780 ref
->u
.ss
.start
= start
;
13781 if (end
== NULL
&& e
->ts
.u
.cl
)
13782 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13783 ref
->u
.ss
.end
= end
;
13784 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13791 /* Any further ref is an error. */
13794 gcc_assert (ref
->type
== REF_ARRAY
);
13795 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13801 if (gfc_resolve_expr (e
) == FAILURE
)
13804 sym
= e
->symtree
->n
.sym
;
13806 if (sym
->attr
.is_protected
)
13808 if (cnt_protected
> 0 && cnt_protected
!= object
)
13810 gfc_error ("Either all or none of the objects in the "
13811 "EQUIVALENCE set at %L shall have the "
13812 "PROTECTED attribute",
13817 /* Shall not equivalence common block variables in a PURE procedure. */
13818 if (sym
->ns
->proc_name
13819 && sym
->ns
->proc_name
->attr
.pure
13820 && sym
->attr
.in_common
)
13822 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13823 "object in the pure procedure '%s'",
13824 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13828 /* Shall not be a named constant. */
13829 if (e
->expr_type
== EXPR_CONSTANT
)
13831 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13832 "object", sym
->name
, &e
->where
);
13836 if (e
->ts
.type
== BT_DERIVED
13837 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13840 /* Check that the types correspond correctly:
13842 A numeric sequence structure may be equivalenced to another sequence
13843 structure, an object of default integer type, default real type, double
13844 precision real type, default logical type such that components of the
13845 structure ultimately only become associated to objects of the same
13846 kind. A character sequence structure may be equivalenced to an object
13847 of default character kind or another character sequence structure.
13848 Other objects may be equivalenced only to objects of the same type and
13849 kind parameters. */
13851 /* Identical types are unconditionally OK. */
13852 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13853 goto identical_types
;
13855 last_eq_type
= sequence_type (*last_ts
);
13856 eq_type
= sequence_type (sym
->ts
);
13858 /* Since the pair of objects is not of the same type, mixed or
13859 non-default sequences can be rejected. */
13861 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13862 "statement at %L with different type objects";
13864 && last_eq_type
== SEQ_MIXED
13865 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13867 || (eq_type
== SEQ_MIXED
13868 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13869 &e
->where
) == FAILURE
))
13872 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13873 "statement at %L with objects of different type";
13875 && last_eq_type
== SEQ_NONDEFAULT
13876 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13877 last_where
) == FAILURE
)
13878 || (eq_type
== SEQ_NONDEFAULT
13879 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13880 &e
->where
) == FAILURE
))
13883 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13884 "EQUIVALENCE statement at %L";
13885 if (last_eq_type
== SEQ_CHARACTER
13886 && eq_type
!= SEQ_CHARACTER
13887 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13888 &e
->where
) == FAILURE
)
13891 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13892 "EQUIVALENCE statement at %L";
13893 if (last_eq_type
== SEQ_NUMERIC
13894 && eq_type
!= SEQ_NUMERIC
13895 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13896 &e
->where
) == FAILURE
)
13901 last_where
= &e
->where
;
13906 /* Shall not be an automatic array. */
13907 if (e
->ref
->type
== REF_ARRAY
13908 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13910 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13911 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13918 /* Shall not be a structure component. */
13919 if (r
->type
== REF_COMPONENT
)
13921 gfc_error ("Structure component '%s' at %L cannot be an "
13922 "EQUIVALENCE object",
13923 r
->u
.c
.component
->name
, &e
->where
);
13927 /* A substring shall not have length zero. */
13928 if (r
->type
== REF_SUBSTRING
)
13930 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13932 gfc_error ("Substring at %L has length zero",
13933 &r
->u
.ss
.start
->where
);
13943 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13946 resolve_fntype (gfc_namespace
*ns
)
13948 gfc_entry_list
*el
;
13951 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13954 /* If there are any entries, ns->proc_name is the entry master
13955 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13957 sym
= ns
->entries
->sym
;
13959 sym
= ns
->proc_name
;
13960 if (sym
->result
== sym
13961 && sym
->ts
.type
== BT_UNKNOWN
13962 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13963 && !sym
->attr
.untyped
)
13965 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13966 sym
->name
, &sym
->declared_at
);
13967 sym
->attr
.untyped
= 1;
13970 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13971 && !sym
->attr
.contained
13972 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
13973 && gfc_check_symbol_access (sym
))
13975 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
13976 "%L of PRIVATE type '%s'", sym
->name
,
13977 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13981 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13983 if (el
->sym
->result
== el
->sym
13984 && el
->sym
->ts
.type
== BT_UNKNOWN
13985 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13986 && !el
->sym
->attr
.untyped
)
13988 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13989 el
->sym
->name
, &el
->sym
->declared_at
);
13990 el
->sym
->attr
.untyped
= 1;
13996 /* 12.3.2.1.1 Defined operators. */
13999 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14001 gfc_formal_arglist
*formal
;
14003 if (!sym
->attr
.function
)
14005 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14006 sym
->name
, &where
);
14010 if (sym
->ts
.type
== BT_CHARACTER
14011 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14012 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14013 && sym
->result
->ts
.u
.cl
->length
))
14015 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14016 "character length", sym
->name
, &where
);
14020 formal
= sym
->formal
;
14021 if (!formal
|| !formal
->sym
)
14023 gfc_error ("User operator procedure '%s' at %L must have at least "
14024 "one argument", sym
->name
, &where
);
14028 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14030 gfc_error ("First argument of operator interface at %L must be "
14031 "INTENT(IN)", &where
);
14035 if (formal
->sym
->attr
.optional
)
14037 gfc_error ("First argument of operator interface at %L cannot be "
14038 "optional", &where
);
14042 formal
= formal
->next
;
14043 if (!formal
|| !formal
->sym
)
14046 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14048 gfc_error ("Second argument of operator interface at %L must be "
14049 "INTENT(IN)", &where
);
14053 if (formal
->sym
->attr
.optional
)
14055 gfc_error ("Second argument of operator interface at %L cannot be "
14056 "optional", &where
);
14062 gfc_error ("Operator interface at %L must have, at most, two "
14063 "arguments", &where
);
14071 gfc_resolve_uops (gfc_symtree
*symtree
)
14073 gfc_interface
*itr
;
14075 if (symtree
== NULL
)
14078 gfc_resolve_uops (symtree
->left
);
14079 gfc_resolve_uops (symtree
->right
);
14081 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14082 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14086 /* Examine all of the expressions associated with a program unit,
14087 assign types to all intermediate expressions, make sure that all
14088 assignments are to compatible types and figure out which names
14089 refer to which functions or subroutines. It doesn't check code
14090 block, which is handled by resolve_code. */
14093 resolve_types (gfc_namespace
*ns
)
14099 gfc_namespace
* old_ns
= gfc_current_ns
;
14101 /* Check that all IMPLICIT types are ok. */
14102 if (!ns
->seen_implicit_none
)
14105 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14106 if (ns
->set_flag
[letter
]
14107 && resolve_typespec_used (&ns
->default_type
[letter
],
14108 &ns
->implicit_loc
[letter
],
14113 gfc_current_ns
= ns
;
14115 resolve_entries (ns
);
14117 resolve_common_vars (ns
->blank_common
.head
, false);
14118 resolve_common_blocks (ns
->common_root
);
14120 resolve_contained_functions (ns
);
14122 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14123 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14124 resolve_formal_arglist (ns
->proc_name
);
14126 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14128 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14129 resolve_charlen (cl
);
14131 gfc_traverse_ns (ns
, resolve_symbol
);
14133 resolve_fntype (ns
);
14135 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14137 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14138 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14139 "also be PURE", n
->proc_name
->name
,
14140 &n
->proc_name
->declared_at
);
14146 do_concurrent_flag
= 0;
14147 gfc_check_interfaces (ns
);
14149 gfc_traverse_ns (ns
, resolve_values
);
14155 for (d
= ns
->data
; d
; d
= d
->next
)
14159 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14161 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14163 if (ns
->common_root
!= NULL
)
14164 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
14166 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14167 resolve_equivalence (eq
);
14169 /* Warn about unused labels. */
14170 if (warn_unused_label
)
14171 warn_unused_fortran_label (ns
->st_labels
);
14173 gfc_resolve_uops (ns
->uop_root
);
14175 gfc_current_ns
= old_ns
;
14179 /* Call resolve_code recursively. */
14182 resolve_codes (gfc_namespace
*ns
)
14185 bitmap_obstack old_obstack
;
14187 if (ns
->resolved
== 1)
14190 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14193 gfc_current_ns
= ns
;
14195 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14196 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14199 /* Set to an out of range value. */
14200 current_entry_id
= -1;
14202 old_obstack
= labels_obstack
;
14203 bitmap_obstack_initialize (&labels_obstack
);
14205 resolve_code (ns
->code
, ns
);
14207 bitmap_obstack_release (&labels_obstack
);
14208 labels_obstack
= old_obstack
;
14212 /* This function is called after a complete program unit has been compiled.
14213 Its purpose is to examine all of the expressions associated with a program
14214 unit, assign types to all intermediate expressions, make sure that all
14215 assignments are to compatible types and figure out which names refer to
14216 which functions or subroutines. */
14219 gfc_resolve (gfc_namespace
*ns
)
14221 gfc_namespace
*old_ns
;
14222 code_stack
*old_cs_base
;
14228 old_ns
= gfc_current_ns
;
14229 old_cs_base
= cs_base
;
14231 resolve_types (ns
);
14232 resolve_codes (ns
);
14234 gfc_current_ns
= old_ns
;
14235 cs_base
= old_cs_base
;
14238 gfc_run_passes (ns
);