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/>. */
29 #include "arith.h" /* For gfc_compare_expr(). */
30 #include "dependency.h"
32 #include "target-memory.h" /* for gfc_simplify_transfer */
33 #include "constructor.h"
35 /* Types used in equivalence statements. */
39 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
43 /* Stack to keep track of the nesting of blocks as we move through the
44 code. See resolve_branch() and resolve_code(). */
46 typedef struct code_stack
48 struct gfc_code
*head
, *current
;
49 struct code_stack
*prev
;
51 /* This bitmap keeps track of the targets valid for a branch from
52 inside this block except for END {IF|SELECT}s of enclosing
54 bitmap reachable_labels
;
58 static code_stack
*cs_base
= NULL
;
61 /* Nonzero if we're inside a FORALL block. */
63 static int forall_flag
;
65 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
67 static int omp_workshare_flag
;
69 /* Nonzero if we are processing a formal arglist. The corresponding function
70 resets the flag each time that it is read. */
71 static int formal_arg_flag
= 0;
73 /* True if we are resolving a specification expression. */
74 static int specification_expr
= 0;
76 /* The id of the last entry seen. */
77 static int current_entry_id
;
79 /* We use bitmaps to determine if a branch target is valid. */
80 static bitmap_obstack labels_obstack
;
82 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
83 static bool inquiry_argument
= false;
86 gfc_is_formal_arg (void)
88 return formal_arg_flag
;
91 /* Is the symbol host associated? */
93 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
95 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
104 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
105 an ABSTRACT derived-type. If where is not NULL, an error message with that
106 locus is printed, optionally using name. */
109 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
111 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
116 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
117 name
, where
, ts
->u
.derived
->name
);
119 gfc_error ("ABSTRACT type '%s' used at %L",
120 ts
->u
.derived
->name
, where
);
130 static void resolve_symbol (gfc_symbol
*sym
);
131 static gfc_try
resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
);
134 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
137 resolve_procedure_interface (gfc_symbol
*sym
)
139 if (sym
->ts
.interface
== sym
)
141 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
142 sym
->name
, &sym
->declared_at
);
145 if (sym
->ts
.interface
->attr
.procedure
)
147 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
148 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
149 sym
->name
, &sym
->declared_at
);
153 /* Get the attributes from the interface (now resolved). */
154 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
156 gfc_symbol
*ifc
= sym
->ts
.interface
;
157 resolve_symbol (ifc
);
159 if (ifc
->attr
.intrinsic
)
160 resolve_intrinsic (ifc
, &ifc
->declared_at
);
163 sym
->ts
= ifc
->result
->ts
;
166 sym
->ts
.interface
= ifc
;
167 sym
->attr
.function
= ifc
->attr
.function
;
168 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
169 gfc_copy_formal_args (sym
, ifc
);
171 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
172 sym
->attr
.pointer
= ifc
->attr
.pointer
;
173 sym
->attr
.pure
= ifc
->attr
.pure
;
174 sym
->attr
.elemental
= ifc
->attr
.elemental
;
175 sym
->attr
.dimension
= ifc
->attr
.dimension
;
176 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
177 sym
->attr
.recursive
= ifc
->attr
.recursive
;
178 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
179 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
180 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
181 /* Copy array spec. */
182 sym
->as
= gfc_copy_array_spec (ifc
->as
);
186 for (i
= 0; i
< sym
->as
->rank
; i
++)
188 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
189 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
192 /* Copy char length. */
193 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
195 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
196 gfc_expr_replace_symbols (sym
->ts
.u
.cl
->length
, sym
);
197 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
198 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
202 else if (sym
->ts
.interface
->name
[0] != '\0')
204 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
205 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
213 /* Resolve types of formal argument lists. These have to be done early so that
214 the formal argument lists of module procedures can be copied to the
215 containing module before the individual procedures are resolved
216 individually. We also resolve argument lists of procedures in interface
217 blocks because they are self-contained scoping units.
219 Since a dummy argument cannot be a non-dummy procedure, the only
220 resort left for untyped names are the IMPLICIT types. */
223 resolve_formal_arglist (gfc_symbol
*proc
)
225 gfc_formal_arglist
*f
;
229 if (proc
->result
!= NULL
)
234 if (gfc_elemental (proc
)
235 || sym
->attr
.pointer
|| sym
->attr
.allocatable
236 || (sym
->as
&& sym
->as
->rank
> 0))
238 proc
->attr
.always_explicit
= 1;
239 sym
->attr
.always_explicit
= 1;
244 for (f
= proc
->formal
; f
; f
= f
->next
)
250 /* Alternate return placeholder. */
251 if (gfc_elemental (proc
))
252 gfc_error ("Alternate return specifier in elemental subroutine "
253 "'%s' at %L is not allowed", proc
->name
,
255 if (proc
->attr
.function
)
256 gfc_error ("Alternate return specifier in function "
257 "'%s' at %L is not allowed", proc
->name
,
261 else if (sym
->attr
.procedure
&& sym
->ts
.interface
262 && sym
->attr
.if_source
!= IFSRC_DECL
)
263 resolve_procedure_interface (sym
);
265 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
266 resolve_formal_arglist (sym
);
268 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
270 if (gfc_pure (proc
) && !gfc_pure (sym
))
272 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
273 "also be PURE", sym
->name
, &sym
->declared_at
);
277 if (proc
->attr
.implicit_pure
&& !gfc_pure(sym
))
278 proc
->attr
.implicit_pure
= 0;
280 if (gfc_elemental (proc
))
282 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
283 "procedure", &sym
->declared_at
);
287 if (sym
->attr
.function
288 && sym
->ts
.type
== BT_UNKNOWN
289 && sym
->attr
.intrinsic
)
291 gfc_intrinsic_sym
*isym
;
292 isym
= gfc_find_function (sym
->name
);
293 if (isym
== NULL
|| !isym
->specific
)
295 gfc_error ("Unable to find a specific INTRINSIC procedure "
296 "for the reference '%s' at %L", sym
->name
,
305 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
306 && (!sym
->attr
.function
|| sym
->result
== sym
))
307 gfc_set_default_type (sym
, 1, sym
->ns
);
309 gfc_resolve_array_spec (sym
->as
, 0);
311 /* We can't tell if an array with dimension (:) is assumed or deferred
312 shape until we know if it has the pointer or allocatable attributes.
314 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
315 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
317 sym
->as
->type
= AS_ASSUMED_SHAPE
;
318 for (i
= 0; i
< sym
->as
->rank
; i
++)
319 sym
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
323 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
324 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
325 || sym
->attr
.optional
)
327 proc
->attr
.always_explicit
= 1;
329 proc
->result
->attr
.always_explicit
= 1;
332 /* If the flavor is unknown at this point, it has to be a variable.
333 A procedure specification would have already set the type. */
335 if (sym
->attr
.flavor
== FL_UNKNOWN
)
336 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
338 if (gfc_pure (proc
) && !sym
->attr
.pointer
339 && sym
->attr
.flavor
!= FL_PROCEDURE
)
341 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
343 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
344 "INTENT(IN) or VALUE", sym
->name
, proc
->name
,
347 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
349 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
350 "have its INTENT specified or have the VALUE "
351 "attribute", sym
->name
, proc
->name
, &sym
->declared_at
);
354 if (proc
->attr
.implicit_pure
&& !sym
->attr
.pointer
355 && sym
->attr
.flavor
!= FL_PROCEDURE
)
357 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
358 proc
->attr
.implicit_pure
= 0;
360 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
361 proc
->attr
.implicit_pure
= 0;
364 if (gfc_elemental (proc
))
367 if (sym
->attr
.codimension
)
369 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
370 "procedure", sym
->name
, &sym
->declared_at
);
376 gfc_error ("Argument '%s' of elemental procedure at %L must "
377 "be scalar", sym
->name
, &sym
->declared_at
);
381 if (sym
->attr
.allocatable
)
383 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
384 "have the ALLOCATABLE attribute", sym
->name
,
389 if (sym
->attr
.pointer
)
391 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
392 "have the POINTER attribute", sym
->name
,
397 if (sym
->attr
.flavor
== FL_PROCEDURE
)
399 gfc_error ("Dummy procedure '%s' not allowed in elemental "
400 "procedure '%s' at %L", sym
->name
, proc
->name
,
405 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
407 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
408 "have its INTENT specified", sym
->name
, proc
->name
,
414 /* Each dummy shall be specified to be scalar. */
415 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
419 gfc_error ("Argument '%s' of statement function at %L must "
420 "be scalar", sym
->name
, &sym
->declared_at
);
424 if (sym
->ts
.type
== BT_CHARACTER
)
426 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
427 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
429 gfc_error ("Character-valued argument '%s' of statement "
430 "function at %L must have constant length",
431 sym
->name
, &sym
->declared_at
);
441 /* Work function called when searching for symbols that have argument lists
442 associated with them. */
445 find_arglists (gfc_symbol
*sym
)
447 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
450 resolve_formal_arglist (sym
);
454 /* Given a namespace, resolve all formal argument lists within the namespace.
458 resolve_formal_arglists (gfc_namespace
*ns
)
463 gfc_traverse_ns (ns
, find_arglists
);
468 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
472 /* If this namespace is not a function or an entry master function,
474 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
475 || sym
->attr
.entry_master
)
478 /* Try to find out of what the return type is. */
479 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
481 t
= gfc_set_default_type (sym
->result
, 0, ns
);
483 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
485 if (sym
->result
== sym
)
486 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
487 sym
->name
, &sym
->declared_at
);
488 else if (!sym
->result
->attr
.proc_pointer
)
489 gfc_error ("Result '%s' of contained function '%s' at %L has "
490 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
491 &sym
->result
->declared_at
);
492 sym
->result
->attr
.untyped
= 1;
496 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
497 type, lists the only ways a character length value of * can be used:
498 dummy arguments of procedures, named constants, and function results
499 in external functions. Internal function results and results of module
500 procedures are not on this list, ergo, not permitted. */
502 if (sym
->result
->ts
.type
== BT_CHARACTER
)
504 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
505 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
507 /* See if this is a module-procedure and adapt error message
510 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
511 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
513 gfc_error ("Character-valued %s '%s' at %L must not be"
515 module_proc
? _("module procedure")
516 : _("internal function"),
517 sym
->name
, &sym
->declared_at
);
523 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
524 introduce duplicates. */
527 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
529 gfc_formal_arglist
*f
, *new_arglist
;
532 for (; new_args
!= NULL
; new_args
= new_args
->next
)
534 new_sym
= new_args
->sym
;
535 /* See if this arg is already in the formal argument list. */
536 for (f
= proc
->formal
; f
; f
= f
->next
)
538 if (new_sym
== f
->sym
)
545 /* Add a new argument. Argument order is not important. */
546 new_arglist
= gfc_get_formal_arglist ();
547 new_arglist
->sym
= new_sym
;
548 new_arglist
->next
= proc
->formal
;
549 proc
->formal
= new_arglist
;
554 /* Flag the arguments that are not present in all entries. */
557 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
559 gfc_formal_arglist
*f
, *head
;
562 for (f
= proc
->formal
; f
; f
= f
->next
)
567 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
569 if (new_args
->sym
== f
->sym
)
576 f
->sym
->attr
.not_always_present
= 1;
581 /* Resolve alternate entry points. If a symbol has multiple entry points we
582 create a new master symbol for the main routine, and turn the existing
583 symbol into an entry point. */
586 resolve_entries (gfc_namespace
*ns
)
588 gfc_namespace
*old_ns
;
592 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
593 static int master_count
= 0;
595 if (ns
->proc_name
== NULL
)
598 /* No need to do anything if this procedure doesn't have alternate entry
603 /* We may already have resolved alternate entry points. */
604 if (ns
->proc_name
->attr
.entry_master
)
607 /* If this isn't a procedure something has gone horribly wrong. */
608 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
610 /* Remember the current namespace. */
611 old_ns
= gfc_current_ns
;
615 /* Add the main entry point to the list of entry points. */
616 el
= gfc_get_entry_list ();
617 el
->sym
= ns
->proc_name
;
619 el
->next
= ns
->entries
;
621 ns
->proc_name
->attr
.entry
= 1;
623 /* If it is a module function, it needs to be in the right namespace
624 so that gfc_get_fake_result_decl can gather up the results. The
625 need for this arose in get_proc_name, where these beasts were
626 left in their own namespace, to keep prior references linked to
627 the entry declaration.*/
628 if (ns
->proc_name
->attr
.function
629 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
632 /* Do the same for entries where the master is not a module
633 procedure. These are retained in the module namespace because
634 of the module procedure declaration. */
635 for (el
= el
->next
; el
; el
= el
->next
)
636 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
637 && el
->sym
->attr
.mod_proc
)
641 /* Add an entry statement for it. */
648 /* Create a new symbol for the master function. */
649 /* Give the internal function a unique name (within this file).
650 Also include the function name so the user has some hope of figuring
651 out what is going on. */
652 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
653 master_count
++, ns
->proc_name
->name
);
654 gfc_get_ha_symbol (name
, &proc
);
655 gcc_assert (proc
!= NULL
);
657 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
658 if (ns
->proc_name
->attr
.subroutine
)
659 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
663 gfc_typespec
*ts
, *fts
;
664 gfc_array_spec
*as
, *fas
;
665 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
667 fas
= ns
->entries
->sym
->as
;
668 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
669 fts
= &ns
->entries
->sym
->result
->ts
;
670 if (fts
->type
== BT_UNKNOWN
)
671 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
672 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
674 ts
= &el
->sym
->result
->ts
;
676 as
= as
? as
: el
->sym
->result
->as
;
677 if (ts
->type
== BT_UNKNOWN
)
678 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
680 if (! gfc_compare_types (ts
, fts
)
681 || (el
->sym
->result
->attr
.dimension
682 != ns
->entries
->sym
->result
->attr
.dimension
)
683 || (el
->sym
->result
->attr
.pointer
684 != ns
->entries
->sym
->result
->attr
.pointer
))
686 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
687 && gfc_compare_array_spec (as
, fas
) == 0)
688 gfc_error ("Function %s at %L has entries with mismatched "
689 "array specifications", ns
->entries
->sym
->name
,
690 &ns
->entries
->sym
->declared_at
);
691 /* The characteristics need to match and thus both need to have
692 the same string length, i.e. both len=*, or both len=4.
693 Having both len=<variable> is also possible, but difficult to
694 check at compile time. */
695 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
696 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
697 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
699 && ts
->u
.cl
->length
->expr_type
700 != fts
->u
.cl
->length
->expr_type
)
702 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
703 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
704 fts
->u
.cl
->length
->value
.integer
) != 0)))
705 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
706 "entries returning variables of different "
707 "string lengths", ns
->entries
->sym
->name
,
708 &ns
->entries
->sym
->declared_at
);
713 sym
= ns
->entries
->sym
->result
;
714 /* All result types the same. */
716 if (sym
->attr
.dimension
)
717 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
718 if (sym
->attr
.pointer
)
719 gfc_add_pointer (&proc
->attr
, NULL
);
723 /* Otherwise the result will be passed through a union by
725 proc
->attr
.mixed_entry_master
= 1;
726 for (el
= ns
->entries
; el
; el
= el
->next
)
728 sym
= el
->sym
->result
;
729 if (sym
->attr
.dimension
)
731 if (el
== ns
->entries
)
732 gfc_error ("FUNCTION result %s can't be an array in "
733 "FUNCTION %s at %L", sym
->name
,
734 ns
->entries
->sym
->name
, &sym
->declared_at
);
736 gfc_error ("ENTRY result %s can't be an array in "
737 "FUNCTION %s at %L", sym
->name
,
738 ns
->entries
->sym
->name
, &sym
->declared_at
);
740 else if (sym
->attr
.pointer
)
742 if (el
== ns
->entries
)
743 gfc_error ("FUNCTION result %s can't be a POINTER in "
744 "FUNCTION %s at %L", sym
->name
,
745 ns
->entries
->sym
->name
, &sym
->declared_at
);
747 gfc_error ("ENTRY result %s can't be a POINTER in "
748 "FUNCTION %s at %L", sym
->name
,
749 ns
->entries
->sym
->name
, &sym
->declared_at
);
754 if (ts
->type
== BT_UNKNOWN
)
755 ts
= gfc_get_default_type (sym
->name
, NULL
);
759 if (ts
->kind
== gfc_default_integer_kind
)
763 if (ts
->kind
== gfc_default_real_kind
764 || ts
->kind
== gfc_default_double_kind
)
768 if (ts
->kind
== gfc_default_complex_kind
)
772 if (ts
->kind
== gfc_default_logical_kind
)
776 /* We will issue error elsewhere. */
784 if (el
== ns
->entries
)
785 gfc_error ("FUNCTION result %s can't be of type %s "
786 "in FUNCTION %s at %L", sym
->name
,
787 gfc_typename (ts
), ns
->entries
->sym
->name
,
790 gfc_error ("ENTRY result %s can't be of type %s "
791 "in FUNCTION %s at %L", sym
->name
,
792 gfc_typename (ts
), ns
->entries
->sym
->name
,
799 proc
->attr
.access
= ACCESS_PRIVATE
;
800 proc
->attr
.entry_master
= 1;
802 /* Merge all the entry point arguments. */
803 for (el
= ns
->entries
; el
; el
= el
->next
)
804 merge_argument_lists (proc
, el
->sym
->formal
);
806 /* Check the master formal arguments for any that are not
807 present in all entry points. */
808 for (el
= ns
->entries
; el
; el
= el
->next
)
809 check_argument_lists (proc
, el
->sym
->formal
);
811 /* Use the master function for the function body. */
812 ns
->proc_name
= proc
;
814 /* Finalize the new symbols. */
815 gfc_commit_symbols ();
817 /* Restore the original namespace. */
818 gfc_current_ns
= old_ns
;
822 /* Resolve common variables. */
824 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
826 gfc_symbol
*csym
= sym
;
828 for (; csym
; csym
= csym
->common_next
)
830 if (csym
->value
|| csym
->attr
.data
)
832 if (!csym
->ns
->is_block_data
)
833 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
834 "but only in BLOCK DATA initialization is "
835 "allowed", csym
->name
, &csym
->declared_at
);
836 else if (!named_common
)
837 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
838 "in a blank COMMON but initialization is only "
839 "allowed in named common blocks", csym
->name
,
843 if (csym
->ts
.type
!= BT_DERIVED
)
846 if (!(csym
->ts
.u
.derived
->attr
.sequence
847 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
848 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
849 "has neither the SEQUENCE nor the BIND(C) "
850 "attribute", csym
->name
, &csym
->declared_at
);
851 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
852 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
853 "has an ultimate component that is "
854 "allocatable", csym
->name
, &csym
->declared_at
);
855 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
856 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
857 "may not have default initializer", csym
->name
,
860 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
861 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
865 /* Resolve common blocks. */
867 resolve_common_blocks (gfc_symtree
*common_root
)
871 if (common_root
== NULL
)
874 if (common_root
->left
)
875 resolve_common_blocks (common_root
->left
);
876 if (common_root
->right
)
877 resolve_common_blocks (common_root
->right
);
879 resolve_common_vars (common_root
->n
.common
->head
, true);
881 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
885 if (sym
->attr
.flavor
== FL_PARAMETER
)
886 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
887 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
889 if (sym
->attr
.intrinsic
)
890 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
891 sym
->name
, &common_root
->n
.common
->where
);
892 else if (sym
->attr
.result
893 || gfc_is_function_return_value (sym
, gfc_current_ns
))
894 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
895 "that is also a function result", sym
->name
,
896 &common_root
->n
.common
->where
);
897 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
898 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
899 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
900 "that is also a global procedure", sym
->name
,
901 &common_root
->n
.common
->where
);
905 /* Resolve contained function types. Because contained functions can call one
906 another, they have to be worked out before any of the contained procedures
909 The good news is that if a function doesn't already have a type, the only
910 way it can get one is through an IMPLICIT type or a RESULT variable, because
911 by definition contained functions are contained namespace they're contained
912 in, not in a sibling or parent namespace. */
915 resolve_contained_functions (gfc_namespace
*ns
)
917 gfc_namespace
*child
;
920 resolve_formal_arglists (ns
);
922 for (child
= ns
->contained
; child
; child
= child
->sibling
)
924 /* Resolve alternate entry points first. */
925 resolve_entries (child
);
927 /* Then check function return types. */
928 resolve_contained_fntype (child
->proc_name
, child
);
929 for (el
= child
->entries
; el
; el
= el
->next
)
930 resolve_contained_fntype (el
->sym
, child
);
935 /* Resolve all of the elements of a structure constructor and make sure that
936 the types are correct. The 'init' flag indicates that the given
937 constructor is an initializer. */
940 resolve_structure_cons (gfc_expr
*expr
, int init
)
942 gfc_constructor
*cons
;
949 if (expr
->ts
.type
== BT_DERIVED
)
950 resolve_symbol (expr
->ts
.u
.derived
);
952 cons
= gfc_constructor_first (expr
->value
.constructor
);
953 /* A constructor may have references if it is the result of substituting a
954 parameter variable. In this case we just pull out the component we
957 comp
= expr
->ref
->u
.c
.sym
->components
;
959 comp
= expr
->ts
.u
.derived
->components
;
961 /* See if the user is trying to invoke a structure constructor for one of
962 the iso_c_binding derived types. */
963 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
964 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
965 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
967 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
968 expr
->ts
.u
.derived
->name
, &(expr
->where
));
972 /* Return if structure constructor is c_null_(fun)prt. */
973 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
974 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
975 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
978 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
985 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
991 rank
= comp
->as
? comp
->as
->rank
: 0;
992 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
993 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
995 gfc_error ("The rank of the element in the derived type "
996 "constructor at %L does not match that of the "
997 "component (%d/%d)", &cons
->expr
->where
,
998 cons
->expr
->rank
, rank
);
1002 /* If we don't have the right type, try to convert it. */
1004 if (!comp
->attr
.proc_pointer
&&
1005 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1008 if (strcmp (comp
->name
, "_extends") == 0)
1010 /* Can afford to be brutal with the _extends initializer.
1011 The derived type can get lost because it is PRIVATE
1012 but it is not usage constrained by the standard. */
1013 cons
->expr
->ts
= comp
->ts
;
1016 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1017 gfc_error ("The element in the derived type constructor at %L, "
1018 "for pointer component '%s', is %s but should be %s",
1019 &cons
->expr
->where
, comp
->name
,
1020 gfc_basic_typename (cons
->expr
->ts
.type
),
1021 gfc_basic_typename (comp
->ts
.type
));
1023 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1026 /* For strings, the length of the constructor should be the same as
1027 the one of the structure, ensure this if the lengths are known at
1028 compile time and when we are dealing with PARAMETER or structure
1030 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1031 && comp
->ts
.u
.cl
->length
1032 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1033 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1034 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1035 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1036 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1038 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1039 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1041 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1042 to make use of the gfc_resolve_character_array_constructor
1043 machinery. The expression is later simplified away to
1044 an array of string literals. */
1045 gfc_expr
*para
= cons
->expr
;
1046 cons
->expr
= gfc_get_expr ();
1047 cons
->expr
->ts
= para
->ts
;
1048 cons
->expr
->where
= para
->where
;
1049 cons
->expr
->expr_type
= EXPR_ARRAY
;
1050 cons
->expr
->rank
= para
->rank
;
1051 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1052 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1053 para
, &cons
->expr
->where
);
1055 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1058 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1059 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1061 gfc_charlen
*cl
, *cl2
;
1064 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1066 if (cl
== cons
->expr
->ts
.u
.cl
)
1074 cl2
->next
= cl
->next
;
1076 gfc_free_expr (cl
->length
);
1080 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1081 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1082 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1083 gfc_resolve_character_array_constructor (cons
->expr
);
1087 if (cons
->expr
->expr_type
== EXPR_NULL
1088 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1089 || comp
->attr
.proc_pointer
1090 || (comp
->ts
.type
== BT_CLASS
1091 && (CLASS_DATA (comp
)->attr
.class_pointer
1092 || CLASS_DATA (comp
)->attr
.allocatable
))))
1095 gfc_error ("The NULL in the derived type constructor at %L is "
1096 "being applied to component '%s', which is neither "
1097 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1101 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1102 || cons
->expr
->expr_type
== EXPR_NULL
)
1105 a
= gfc_expr_attr (cons
->expr
);
1107 if (!a
.pointer
&& !a
.target
)
1110 gfc_error ("The element in the derived type constructor at %L, "
1111 "for pointer component '%s' should be a POINTER or "
1112 "a TARGET", &cons
->expr
->where
, comp
->name
);
1117 /* F08:C461. Additional checks for pointer initialization. */
1121 gfc_error ("Pointer initialization target at %L "
1122 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1127 gfc_error ("Pointer initialization target at %L "
1128 "must have the SAVE attribute", &cons
->expr
->where
);
1132 /* F2003, C1272 (3). */
1133 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1134 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1135 || gfc_is_coindexed (cons
->expr
)))
1138 gfc_error ("Invalid expression in the derived type constructor for "
1139 "pointer component '%s' at %L in PURE procedure",
1140 comp
->name
, &cons
->expr
->where
);
1143 if (gfc_implicit_pure (NULL
)
1144 && cons
->expr
->expr_type
== EXPR_VARIABLE
1145 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1146 || gfc_is_coindexed (cons
->expr
)))
1147 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1155 /****************** Expression name resolution ******************/
1157 /* Returns 0 if a symbol was not declared with a type or
1158 attribute declaration statement, nonzero otherwise. */
1161 was_declared (gfc_symbol
*sym
)
1167 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1170 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1171 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1172 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1173 || a
.asynchronous
|| a
.codimension
)
1180 /* Determine if a symbol is generic or not. */
1183 generic_sym (gfc_symbol
*sym
)
1187 if (sym
->attr
.generic
||
1188 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1191 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1194 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1201 return generic_sym (s
);
1208 /* Determine if a symbol is specific or not. */
1211 specific_sym (gfc_symbol
*sym
)
1215 if (sym
->attr
.if_source
== IFSRC_IFBODY
1216 || sym
->attr
.proc
== PROC_MODULE
1217 || sym
->attr
.proc
== PROC_INTERNAL
1218 || sym
->attr
.proc
== PROC_ST_FUNCTION
1219 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1220 || sym
->attr
.external
)
1223 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1226 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1228 return (s
== NULL
) ? 0 : specific_sym (s
);
1232 /* Figure out if the procedure is specific, generic or unknown. */
1235 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1239 procedure_kind (gfc_symbol
*sym
)
1241 if (generic_sym (sym
))
1242 return PTYPE_GENERIC
;
1244 if (specific_sym (sym
))
1245 return PTYPE_SPECIFIC
;
1247 return PTYPE_UNKNOWN
;
1250 /* Check references to assumed size arrays. The flag need_full_assumed_size
1251 is nonzero when matching actual arguments. */
1253 static int need_full_assumed_size
= 0;
1256 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1258 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1261 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1262 What should it be? */
1263 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1264 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1265 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1267 gfc_error ("The upper bound in the last dimension must "
1268 "appear in the reference to the assumed size "
1269 "array '%s' at %L", sym
->name
, &e
->where
);
1276 /* Look for bad assumed size array references in argument expressions
1277 of elemental and array valued intrinsic procedures. Since this is
1278 called from procedure resolution functions, it only recurses at
1282 resolve_assumed_size_actual (gfc_expr
*e
)
1287 switch (e
->expr_type
)
1290 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1295 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1296 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1307 /* Check a generic procedure, passed as an actual argument, to see if
1308 there is a matching specific name. If none, it is an error, and if
1309 more than one, the reference is ambiguous. */
1311 count_specific_procs (gfc_expr
*e
)
1318 sym
= e
->symtree
->n
.sym
;
1320 for (p
= sym
->generic
; p
; p
= p
->next
)
1321 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1323 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1329 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1333 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1334 "argument at %L", sym
->name
, &e
->where
);
1340 /* See if a call to sym could possibly be a not allowed RECURSION because of
1341 a missing RECURIVE declaration. This means that either sym is the current
1342 context itself, or sym is the parent of a contained procedure calling its
1343 non-RECURSIVE containing procedure.
1344 This also works if sym is an ENTRY. */
1347 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1349 gfc_symbol
* proc_sym
;
1350 gfc_symbol
* context_proc
;
1351 gfc_namespace
* real_context
;
1353 if (sym
->attr
.flavor
== FL_PROGRAM
)
1356 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1358 /* If we've got an ENTRY, find real procedure. */
1359 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1360 proc_sym
= sym
->ns
->entries
->sym
;
1364 /* If sym is RECURSIVE, all is well of course. */
1365 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1368 /* Find the context procedure's "real" symbol if it has entries.
1369 We look for a procedure symbol, so recurse on the parents if we don't
1370 find one (like in case of a BLOCK construct). */
1371 for (real_context
= context
; ; real_context
= real_context
->parent
)
1373 /* We should find something, eventually! */
1374 gcc_assert (real_context
);
1376 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1377 : real_context
->proc_name
);
1379 /* In some special cases, there may not be a proc_name, like for this
1381 real(bad_kind()) function foo () ...
1382 when checking the call to bad_kind ().
1383 In these cases, we simply return here and assume that the
1388 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1392 /* A call from sym's body to itself is recursion, of course. */
1393 if (context_proc
== proc_sym
)
1396 /* The same is true if context is a contained procedure and sym the
1398 if (context_proc
->attr
.contained
)
1400 gfc_symbol
* parent_proc
;
1402 gcc_assert (context
->parent
);
1403 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1404 : context
->parent
->proc_name
);
1406 if (parent_proc
== proc_sym
)
1414 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1415 its typespec and formal argument list. */
1418 resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1420 gfc_intrinsic_sym
* isym
= NULL
;
1426 /* We already know this one is an intrinsic, so we don't call
1427 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1428 gfc_find_subroutine directly to check whether it is a function or
1431 if (sym
->intmod_sym_id
)
1432 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1434 isym
= gfc_find_function (sym
->name
);
1438 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1439 && !sym
->attr
.implicit_type
)
1440 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1441 " ignored", sym
->name
, &sym
->declared_at
);
1443 if (!sym
->attr
.function
&&
1444 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1449 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1451 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1453 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1454 " specifier", sym
->name
, &sym
->declared_at
);
1458 if (!sym
->attr
.subroutine
&&
1459 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1464 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1469 gfc_copy_formal_args_intr (sym
, isym
);
1471 /* Check it is actually available in the standard settings. */
1472 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1475 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1476 " available in the current standard settings but %s. Use"
1477 " an appropriate -std=* option or enable -fall-intrinsics"
1478 " in order to use it.",
1479 sym
->name
, &sym
->declared_at
, symstd
);
1487 /* Resolve a procedure expression, like passing it to a called procedure or as
1488 RHS for a procedure pointer assignment. */
1491 resolve_procedure_expression (gfc_expr
* expr
)
1495 if (expr
->expr_type
!= EXPR_VARIABLE
)
1497 gcc_assert (expr
->symtree
);
1499 sym
= expr
->symtree
->n
.sym
;
1501 if (sym
->attr
.intrinsic
)
1502 resolve_intrinsic (sym
, &expr
->where
);
1504 if (sym
->attr
.flavor
!= FL_PROCEDURE
1505 || (sym
->attr
.function
&& sym
->result
== sym
))
1508 /* A non-RECURSIVE procedure that is used as procedure expression within its
1509 own body is in danger of being called recursively. */
1510 if (is_illegal_recursion (sym
, gfc_current_ns
))
1511 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1512 " itself recursively. Declare it RECURSIVE or use"
1513 " -frecursive", sym
->name
, &expr
->where
);
1519 /* Resolve an actual argument list. Most of the time, this is just
1520 resolving the expressions in the list.
1521 The exception is that we sometimes have to decide whether arguments
1522 that look like procedure arguments are really simple variable
1526 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1527 bool no_formal_args
)
1530 gfc_symtree
*parent_st
;
1532 int save_need_full_assumed_size
;
1534 for (; arg
; arg
= arg
->next
)
1539 /* Check the label is a valid branching target. */
1542 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1544 gfc_error ("Label %d referenced at %L is never defined",
1545 arg
->label
->value
, &arg
->label
->where
);
1552 if (e
->expr_type
== EXPR_VARIABLE
1553 && e
->symtree
->n
.sym
->attr
.generic
1555 && count_specific_procs (e
) != 1)
1558 if (e
->ts
.type
!= BT_PROCEDURE
)
1560 save_need_full_assumed_size
= need_full_assumed_size
;
1561 if (e
->expr_type
!= EXPR_VARIABLE
)
1562 need_full_assumed_size
= 0;
1563 if (gfc_resolve_expr (e
) != SUCCESS
)
1565 need_full_assumed_size
= save_need_full_assumed_size
;
1569 /* See if the expression node should really be a variable reference. */
1571 sym
= e
->symtree
->n
.sym
;
1573 if (sym
->attr
.flavor
== FL_PROCEDURE
1574 || sym
->attr
.intrinsic
1575 || sym
->attr
.external
)
1579 /* If a procedure is not already determined to be something else
1580 check if it is intrinsic. */
1581 if (!sym
->attr
.intrinsic
1582 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1583 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1584 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1585 sym
->attr
.intrinsic
= 1;
1587 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1589 gfc_error ("Statement function '%s' at %L is not allowed as an "
1590 "actual argument", sym
->name
, &e
->where
);
1593 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1594 sym
->attr
.subroutine
);
1595 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1597 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1598 "actual argument", sym
->name
, &e
->where
);
1601 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1602 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1604 if (gfc_notify_std (GFC_STD_F2008
,
1605 "Fortran 2008: Internal procedure '%s' is"
1606 " used as actual argument at %L",
1607 sym
->name
, &e
->where
) == FAILURE
)
1611 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1613 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1614 "allowed as an actual argument at %L", sym
->name
,
1618 /* Check if a generic interface has a specific procedure
1619 with the same name before emitting an error. */
1620 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1623 /* Just in case a specific was found for the expression. */
1624 sym
= e
->symtree
->n
.sym
;
1626 /* If the symbol is the function that names the current (or
1627 parent) scope, then we really have a variable reference. */
1629 if (gfc_is_function_return_value (sym
, sym
->ns
))
1632 /* If all else fails, see if we have a specific intrinsic. */
1633 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1635 gfc_intrinsic_sym
*isym
;
1637 isym
= gfc_find_function (sym
->name
);
1638 if (isym
== NULL
|| !isym
->specific
)
1640 gfc_error ("Unable to find a specific INTRINSIC procedure "
1641 "for the reference '%s' at %L", sym
->name
,
1646 sym
->attr
.intrinsic
= 1;
1647 sym
->attr
.function
= 1;
1650 if (gfc_resolve_expr (e
) == FAILURE
)
1655 /* See if the name is a module procedure in a parent unit. */
1657 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1660 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1662 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1666 if (parent_st
== NULL
)
1669 sym
= parent_st
->n
.sym
;
1670 e
->symtree
= parent_st
; /* Point to the right thing. */
1672 if (sym
->attr
.flavor
== FL_PROCEDURE
1673 || sym
->attr
.intrinsic
1674 || sym
->attr
.external
)
1676 if (gfc_resolve_expr (e
) == FAILURE
)
1682 e
->expr_type
= EXPR_VARIABLE
;
1684 if (sym
->as
!= NULL
)
1686 e
->rank
= sym
->as
->rank
;
1687 e
->ref
= gfc_get_ref ();
1688 e
->ref
->type
= REF_ARRAY
;
1689 e
->ref
->u
.ar
.type
= AR_FULL
;
1690 e
->ref
->u
.ar
.as
= sym
->as
;
1693 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1694 primary.c (match_actual_arg). If above code determines that it
1695 is a variable instead, it needs to be resolved as it was not
1696 done at the beginning of this function. */
1697 save_need_full_assumed_size
= need_full_assumed_size
;
1698 if (e
->expr_type
!= EXPR_VARIABLE
)
1699 need_full_assumed_size
= 0;
1700 if (gfc_resolve_expr (e
) != SUCCESS
)
1702 need_full_assumed_size
= save_need_full_assumed_size
;
1705 /* Check argument list functions %VAL, %LOC and %REF. There is
1706 nothing to do for %REF. */
1707 if (arg
->name
&& arg
->name
[0] == '%')
1709 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1711 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1713 gfc_error ("By-value argument at %L is not of numeric "
1720 gfc_error ("By-value argument at %L cannot be an array or "
1721 "an array section", &e
->where
);
1725 /* Intrinsics are still PROC_UNKNOWN here. However,
1726 since same file external procedures are not resolvable
1727 in gfortran, it is a good deal easier to leave them to
1729 if (ptype
!= PROC_UNKNOWN
1730 && ptype
!= PROC_DUMMY
1731 && ptype
!= PROC_EXTERNAL
1732 && ptype
!= PROC_MODULE
)
1734 gfc_error ("By-value argument at %L is not allowed "
1735 "in this context", &e
->where
);
1740 /* Statement functions have already been excluded above. */
1741 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1742 && e
->ts
.type
== BT_PROCEDURE
)
1744 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1746 gfc_error ("Passing internal procedure at %L by location "
1747 "not allowed", &e
->where
);
1753 /* Fortran 2008, C1237. */
1754 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1755 && gfc_has_ultimate_pointer (e
))
1757 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1758 "component", &e
->where
);
1767 /* Do the checks of the actual argument list that are specific to elemental
1768 procedures. If called with c == NULL, we have a function, otherwise if
1769 expr == NULL, we have a subroutine. */
1772 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1774 gfc_actual_arglist
*arg0
;
1775 gfc_actual_arglist
*arg
;
1776 gfc_symbol
*esym
= NULL
;
1777 gfc_intrinsic_sym
*isym
= NULL
;
1779 gfc_intrinsic_arg
*iformal
= NULL
;
1780 gfc_formal_arglist
*eformal
= NULL
;
1781 bool formal_optional
= false;
1782 bool set_by_optional
= false;
1786 /* Is this an elemental procedure? */
1787 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1789 if (expr
->value
.function
.esym
!= NULL
1790 && expr
->value
.function
.esym
->attr
.elemental
)
1792 arg0
= expr
->value
.function
.actual
;
1793 esym
= expr
->value
.function
.esym
;
1795 else if (expr
->value
.function
.isym
!= NULL
1796 && expr
->value
.function
.isym
->elemental
)
1798 arg0
= expr
->value
.function
.actual
;
1799 isym
= expr
->value
.function
.isym
;
1804 else if (c
&& c
->ext
.actual
!= NULL
)
1806 arg0
= c
->ext
.actual
;
1808 if (c
->resolved_sym
)
1809 esym
= c
->resolved_sym
;
1811 esym
= c
->symtree
->n
.sym
;
1814 if (!esym
->attr
.elemental
)
1820 /* The rank of an elemental is the rank of its array argument(s). */
1821 for (arg
= arg0
; arg
; arg
= arg
->next
)
1823 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1825 rank
= arg
->expr
->rank
;
1826 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1827 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1828 set_by_optional
= true;
1830 /* Function specific; set the result rank and shape. */
1834 if (!expr
->shape
&& arg
->expr
->shape
)
1836 expr
->shape
= gfc_get_shape (rank
);
1837 for (i
= 0; i
< rank
; i
++)
1838 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1845 /* If it is an array, it shall not be supplied as an actual argument
1846 to an elemental procedure unless an array of the same rank is supplied
1847 as an actual argument corresponding to a nonoptional dummy argument of
1848 that elemental procedure(12.4.1.5). */
1849 formal_optional
= false;
1851 iformal
= isym
->formal
;
1853 eformal
= esym
->formal
;
1855 for (arg
= arg0
; arg
; arg
= arg
->next
)
1859 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1860 formal_optional
= true;
1861 eformal
= eformal
->next
;
1863 else if (isym
&& iformal
)
1865 if (iformal
->optional
)
1866 formal_optional
= true;
1867 iformal
= iformal
->next
;
1870 formal_optional
= true;
1872 if (pedantic
&& arg
->expr
!= NULL
1873 && arg
->expr
->expr_type
== EXPR_VARIABLE
1874 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1877 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1878 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1880 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1881 "MISSING, it cannot be the actual argument of an "
1882 "ELEMENTAL procedure unless there is a non-optional "
1883 "argument with the same rank (12.4.1.5)",
1884 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1889 for (arg
= arg0
; arg
; arg
= arg
->next
)
1891 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1894 /* Being elemental, the last upper bound of an assumed size array
1895 argument must be present. */
1896 if (resolve_assumed_size_actual (arg
->expr
))
1899 /* Elemental procedure's array actual arguments must conform. */
1902 if (gfc_check_conformance (arg
->expr
, e
,
1903 "elemental procedure") == FAILURE
)
1910 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1911 is an array, the intent inout/out variable needs to be also an array. */
1912 if (rank
> 0 && esym
&& expr
== NULL
)
1913 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1914 arg
= arg
->next
, eformal
= eformal
->next
)
1915 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1916 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1917 && arg
->expr
&& arg
->expr
->rank
== 0)
1919 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1920 "ELEMENTAL subroutine '%s' is a scalar, but another "
1921 "actual argument is an array", &arg
->expr
->where
,
1922 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1923 : "INOUT", eformal
->sym
->name
, esym
->name
);
1930 /* This function does the checking of references to global procedures
1931 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1932 77 and 95 standards. It checks for a gsymbol for the name, making
1933 one if it does not already exist. If it already exists, then the
1934 reference being resolved must correspond to the type of gsymbol.
1935 Otherwise, the new symbol is equipped with the attributes of the
1936 reference. The corresponding code that is called in creating
1937 global entities is parse.c.
1939 In addition, for all but -std=legacy, the gsymbols are used to
1940 check the interfaces of external procedures from the same file.
1941 The namespace of the gsymbol is resolved and then, once this is
1942 done the interface is checked. */
1946 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
1948 if (!gsym_ns
->proc_name
->attr
.recursive
)
1951 if (sym
->ns
== gsym_ns
)
1954 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
1961 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
1963 if (gsym_ns
->entries
)
1965 gfc_entry_list
*entry
= gsym_ns
->entries
;
1967 for (; entry
; entry
= entry
->next
)
1969 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
1971 if (strcmp (gsym_ns
->proc_name
->name
,
1972 sym
->ns
->proc_name
->name
) == 0)
1976 && strcmp (gsym_ns
->proc_name
->name
,
1977 sym
->ns
->parent
->proc_name
->name
) == 0)
1986 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
1987 gfc_actual_arglist
**actual
, int sub
)
1991 enum gfc_symbol_type type
;
1993 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1995 gsym
= gfc_get_gsymbol (sym
->name
);
1997 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1998 gfc_global_used (gsym
, where
);
2000 if (gfc_option
.flag_whole_file
2001 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2002 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2003 && gsym
->type
!= GSYM_UNKNOWN
2005 && gsym
->ns
->resolved
!= -1
2006 && gsym
->ns
->proc_name
2007 && not_in_recursive (sym
, gsym
->ns
)
2008 && not_entry_self_reference (sym
, gsym
->ns
))
2010 gfc_symbol
*def_sym
;
2012 /* Resolve the gsymbol namespace if needed. */
2013 if (!gsym
->ns
->resolved
)
2015 gfc_dt_list
*old_dt_list
;
2016 struct gfc_omp_saved_state old_omp_state
;
2018 /* Stash away derived types so that the backend_decls do not
2020 old_dt_list
= gfc_derived_types
;
2021 gfc_derived_types
= NULL
;
2022 /* And stash away openmp state. */
2023 gfc_omp_save_and_clear_state (&old_omp_state
);
2025 gfc_resolve (gsym
->ns
);
2027 /* Store the new derived types with the global namespace. */
2028 if (gfc_derived_types
)
2029 gsym
->ns
->derived_types
= gfc_derived_types
;
2031 /* Restore the derived types of this namespace. */
2032 gfc_derived_types
= old_dt_list
;
2033 /* And openmp state. */
2034 gfc_omp_restore_state (&old_omp_state
);
2037 /* Make sure that translation for the gsymbol occurs before
2038 the procedure currently being resolved. */
2039 ns
= gfc_global_ns_list
;
2040 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2042 if (ns
->sibling
== gsym
->ns
)
2044 ns
->sibling
= gsym
->ns
->sibling
;
2045 gsym
->ns
->sibling
= gfc_global_ns_list
;
2046 gfc_global_ns_list
= gsym
->ns
;
2051 def_sym
= gsym
->ns
->proc_name
;
2052 if (def_sym
->attr
.entry_master
)
2054 gfc_entry_list
*entry
;
2055 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2056 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2058 def_sym
= entry
->sym
;
2063 /* Differences in constant character lengths. */
2064 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2066 long int l1
= 0, l2
= 0;
2067 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2068 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2071 && cl1
->length
!= NULL
2072 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2073 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2076 && cl2
->length
!= NULL
2077 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2078 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2080 if (l1
&& l2
&& l1
!= l2
)
2081 gfc_error ("Character length mismatch in return type of "
2082 "function '%s' at %L (%ld/%ld)", sym
->name
,
2083 &sym
->declared_at
, l1
, l2
);
2086 /* Type mismatch of function return type and expected type. */
2087 if (sym
->attr
.function
2088 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2089 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2090 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2091 gfc_typename (&def_sym
->ts
));
2093 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2095 gfc_formal_arglist
*arg
= def_sym
->formal
;
2096 for ( ; arg
; arg
= arg
->next
)
2099 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2100 else if (arg
->sym
->attr
.allocatable
2101 || arg
->sym
->attr
.asynchronous
2102 || arg
->sym
->attr
.optional
2103 || arg
->sym
->attr
.pointer
2104 || arg
->sym
->attr
.target
2105 || arg
->sym
->attr
.value
2106 || arg
->sym
->attr
.volatile_
)
2108 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2109 "has an attribute that requires an explicit "
2110 "interface for this procedure", arg
->sym
->name
,
2111 sym
->name
, &sym
->declared_at
);
2114 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2115 else if (arg
->sym
&& arg
->sym
->as
2116 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2118 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2119 "argument '%s' must have an explicit interface",
2120 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2123 /* F2008, 12.4.2.2 (2c) */
2124 else if (arg
->sym
->attr
.codimension
)
2126 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2127 "'%s' must have an explicit interface",
2128 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2131 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2132 else if (false) /* TODO: is a parametrized derived type */
2134 gfc_error ("Procedure '%s' at %L with parametrized derived "
2135 "type argument '%s' must have an explicit "
2136 "interface", sym
->name
, &sym
->declared_at
,
2140 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2141 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2143 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2144 "argument '%s' must have an explicit interface",
2145 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2150 if (def_sym
->attr
.function
)
2152 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2153 if (def_sym
->as
&& def_sym
->as
->rank
2154 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2155 gfc_error ("The reference to function '%s' at %L either needs an "
2156 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2159 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2160 if ((def_sym
->result
->attr
.pointer
2161 || def_sym
->result
->attr
.allocatable
)
2162 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2163 || def_sym
->result
->attr
.pointer
2164 != sym
->result
->attr
.pointer
2165 || def_sym
->result
->attr
.allocatable
2166 != sym
->result
->attr
.allocatable
))
2167 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2168 "result must have an explicit interface", sym
->name
,
2171 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2172 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2173 && def_sym
->ts
.u
.cl
->length
!= NULL
)
2175 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2177 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2178 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2180 gfc_error ("Nonconstant character-length function '%s' at %L "
2181 "must have an explicit interface", sym
->name
,
2187 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2188 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2190 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2191 "interface", sym
->name
, &sym
->declared_at
);
2194 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2195 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2197 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2198 "an explicit interface", sym
->name
, &sym
->declared_at
);
2201 if (gfc_option
.flag_whole_file
== 1
2202 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2203 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2204 gfc_errors_to_warnings (1);
2206 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2207 gfc_procedure_use (def_sym
, actual
, where
);
2209 gfc_errors_to_warnings (0);
2212 if (gsym
->type
== GSYM_UNKNOWN
)
2215 gsym
->where
= *where
;
2222 /************* Function resolution *************/
2224 /* Resolve a function call known to be generic.
2225 Section 14.1.2.4.1. */
2228 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2232 if (sym
->attr
.generic
)
2234 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2237 expr
->value
.function
.name
= s
->name
;
2238 expr
->value
.function
.esym
= s
;
2240 if (s
->ts
.type
!= BT_UNKNOWN
)
2242 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2243 expr
->ts
= s
->result
->ts
;
2246 expr
->rank
= s
->as
->rank
;
2247 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2248 expr
->rank
= s
->result
->as
->rank
;
2250 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2255 /* TODO: Need to search for elemental references in generic
2259 if (sym
->attr
.intrinsic
)
2260 return gfc_intrinsic_func_interface (expr
, 0);
2267 resolve_generic_f (gfc_expr
*expr
)
2272 sym
= expr
->symtree
->n
.sym
;
2276 m
= resolve_generic_f0 (expr
, sym
);
2279 else if (m
== MATCH_ERROR
)
2283 if (sym
->ns
->parent
== NULL
)
2285 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2289 if (!generic_sym (sym
))
2293 /* Last ditch attempt. See if the reference is to an intrinsic
2294 that possesses a matching interface. 14.1.2.4 */
2295 if (sym
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2297 gfc_error ("There is no specific function for the generic '%s' at %L",
2298 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2302 m
= gfc_intrinsic_func_interface (expr
, 0);
2306 gfc_error ("Generic function '%s' at %L is not consistent with a "
2307 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2314 /* Resolve a function call known to be specific. */
2317 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2321 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2323 if (sym
->attr
.dummy
)
2325 sym
->attr
.proc
= PROC_DUMMY
;
2329 sym
->attr
.proc
= PROC_EXTERNAL
;
2333 if (sym
->attr
.proc
== PROC_MODULE
2334 || sym
->attr
.proc
== PROC_ST_FUNCTION
2335 || sym
->attr
.proc
== PROC_INTERNAL
)
2338 if (sym
->attr
.intrinsic
)
2340 m
= gfc_intrinsic_func_interface (expr
, 1);
2344 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2345 "with an intrinsic", sym
->name
, &expr
->where
);
2353 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2356 expr
->ts
= sym
->result
->ts
;
2359 expr
->value
.function
.name
= sym
->name
;
2360 expr
->value
.function
.esym
= sym
;
2361 if (sym
->as
!= NULL
)
2362 expr
->rank
= sym
->as
->rank
;
2369 resolve_specific_f (gfc_expr
*expr
)
2374 sym
= expr
->symtree
->n
.sym
;
2378 m
= resolve_specific_f0 (sym
, expr
);
2381 if (m
== MATCH_ERROR
)
2384 if (sym
->ns
->parent
== NULL
)
2387 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2393 gfc_error ("Unable to resolve the specific function '%s' at %L",
2394 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2400 /* Resolve a procedure call not known to be generic nor specific. */
2403 resolve_unknown_f (gfc_expr
*expr
)
2408 sym
= expr
->symtree
->n
.sym
;
2410 if (sym
->attr
.dummy
)
2412 sym
->attr
.proc
= PROC_DUMMY
;
2413 expr
->value
.function
.name
= sym
->name
;
2417 /* See if we have an intrinsic function reference. */
2419 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2421 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2426 /* The reference is to an external name. */
2428 sym
->attr
.proc
= PROC_EXTERNAL
;
2429 expr
->value
.function
.name
= sym
->name
;
2430 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2432 if (sym
->as
!= NULL
)
2433 expr
->rank
= sym
->as
->rank
;
2435 /* Type of the expression is either the type of the symbol or the
2436 default type of the symbol. */
2439 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2441 if (sym
->ts
.type
!= BT_UNKNOWN
)
2445 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2447 if (ts
->type
== BT_UNKNOWN
)
2449 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2450 sym
->name
, &expr
->where
);
2461 /* Return true, if the symbol is an external procedure. */
2463 is_external_proc (gfc_symbol
*sym
)
2465 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2466 && !(sym
->attr
.intrinsic
2467 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2468 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2469 && !sym
->attr
.proc_pointer
2470 && !sym
->attr
.use_assoc
2478 /* Figure out if a function reference is pure or not. Also set the name
2479 of the function for a potential error message. Return nonzero if the
2480 function is PURE, zero if not. */
2482 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2485 pure_function (gfc_expr
*e
, const char **name
)
2491 if (e
->symtree
!= NULL
2492 && e
->symtree
->n
.sym
!= NULL
2493 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2494 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2496 if (e
->value
.function
.esym
)
2498 pure
= gfc_pure (e
->value
.function
.esym
);
2499 *name
= e
->value
.function
.esym
->name
;
2501 else if (e
->value
.function
.isym
)
2503 pure
= e
->value
.function
.isym
->pure
2504 || e
->value
.function
.isym
->elemental
;
2505 *name
= e
->value
.function
.isym
->name
;
2509 /* Implicit functions are not pure. */
2511 *name
= e
->value
.function
.name
;
2519 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2520 int *f ATTRIBUTE_UNUSED
)
2524 /* Don't bother recursing into other statement functions
2525 since they will be checked individually for purity. */
2526 if (e
->expr_type
!= EXPR_FUNCTION
2528 || e
->symtree
->n
.sym
== sym
2529 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2532 return pure_function (e
, &name
) ? false : true;
2537 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2539 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2544 is_scalar_expr_ptr (gfc_expr
*expr
)
2546 gfc_try retval
= SUCCESS
;
2551 /* See if we have a gfc_ref, which means we have a substring, array
2552 reference, or a component. */
2553 if (expr
->ref
!= NULL
)
2556 while (ref
->next
!= NULL
)
2562 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2563 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2568 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2570 else if (ref
->u
.ar
.type
== AR_FULL
)
2572 /* The user can give a full array if the array is of size 1. */
2573 if (ref
->u
.ar
.as
!= NULL
2574 && ref
->u
.ar
.as
->rank
== 1
2575 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2576 && ref
->u
.ar
.as
->lower
[0] != NULL
2577 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2578 && ref
->u
.ar
.as
->upper
[0] != NULL
2579 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2581 /* If we have a character string, we need to check if
2582 its length is one. */
2583 if (expr
->ts
.type
== BT_CHARACTER
)
2585 if (expr
->ts
.u
.cl
== NULL
2586 || expr
->ts
.u
.cl
->length
== NULL
2587 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2593 /* We have constant lower and upper bounds. If the
2594 difference between is 1, it can be considered a
2596 FIXME: Use gfc_dep_compare_expr instead. */
2597 start
= (int) mpz_get_si
2598 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2599 end
= (int) mpz_get_si
2600 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2601 if (end
- start
+ 1 != 1)
2616 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2618 /* Character string. Make sure it's of length 1. */
2619 if (expr
->ts
.u
.cl
== NULL
2620 || expr
->ts
.u
.cl
->length
== NULL
2621 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2624 else if (expr
->rank
!= 0)
2631 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2632 and, in the case of c_associated, set the binding label based on
2636 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2637 gfc_symbol
**new_sym
)
2639 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2640 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2641 int optional_arg
= 0;
2642 gfc_try retval
= SUCCESS
;
2643 gfc_symbol
*args_sym
;
2644 gfc_typespec
*arg_ts
;
2645 symbol_attribute arg_attr
;
2647 if (args
->expr
->expr_type
== EXPR_CONSTANT
2648 || args
->expr
->expr_type
== EXPR_OP
2649 || args
->expr
->expr_type
== EXPR_NULL
)
2651 gfc_error ("Argument to '%s' at %L is not a variable",
2652 sym
->name
, &(args
->expr
->where
));
2656 args_sym
= args
->expr
->symtree
->n
.sym
;
2658 /* The typespec for the actual arg should be that stored in the expr
2659 and not necessarily that of the expr symbol (args_sym), because
2660 the actual expression could be a part-ref of the expr symbol. */
2661 arg_ts
= &(args
->expr
->ts
);
2662 arg_attr
= gfc_expr_attr (args
->expr
);
2664 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2666 /* If the user gave two args then they are providing something for
2667 the optional arg (the second cptr). Therefore, set the name and
2668 binding label to the c_associated for two cptrs. Otherwise,
2669 set c_associated to expect one cptr. */
2673 sprintf (name
, "%s_2", sym
->name
);
2674 sprintf (binding_label
, "%s_2", sym
->binding_label
);
2680 sprintf (name
, "%s_1", sym
->name
);
2681 sprintf (binding_label
, "%s_1", sym
->binding_label
);
2685 /* Get a new symbol for the version of c_associated that
2687 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
2689 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2690 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2692 sprintf (name
, "%s", sym
->name
);
2693 sprintf (binding_label
, "%s", sym
->binding_label
);
2695 /* Error check the call. */
2696 if (args
->next
!= NULL
)
2698 gfc_error_now ("More actual than formal arguments in '%s' "
2699 "call at %L", name
, &(args
->expr
->where
));
2702 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2707 /* Make sure we have either the target or pointer attribute. */
2708 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2710 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2711 "a TARGET or an associated pointer",
2713 sym
->name
, &(args
->expr
->where
));
2717 if (gfc_is_coindexed (args
->expr
))
2719 gfc_error_now ("Coindexed argument not permitted"
2720 " in '%s' call at %L", name
,
2721 &(args
->expr
->where
));
2725 /* Follow references to make sure there are no array
2727 seen_section
= false;
2729 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2731 if (ref
->type
== REF_ARRAY
)
2733 if (ref
->u
.ar
.type
== AR_SECTION
)
2734 seen_section
= true;
2736 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2739 for (r
= ref
->next
; r
; r
=r
->next
)
2740 if (r
->type
== REF_COMPONENT
)
2742 gfc_error_now ("Array section not permitted"
2743 " in '%s' call at %L", name
,
2744 &(args
->expr
->where
));
2752 if (seen_section
&& retval
== SUCCESS
)
2753 gfc_warning ("Array section in '%s' call at %L", name
,
2754 &(args
->expr
->where
));
2756 /* See if we have interoperable type and type param. */
2757 if (verify_c_interop (arg_ts
) == SUCCESS
2758 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2760 if (args_sym
->attr
.target
== 1)
2762 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2763 has the target attribute and is interoperable. */
2764 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2765 allocatable variable that has the TARGET attribute and
2766 is not an array of zero size. */
2767 if (args_sym
->attr
.allocatable
== 1)
2769 if (args_sym
->attr
.dimension
!= 0
2770 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2772 gfc_error_now ("Allocatable variable '%s' used as a "
2773 "parameter to '%s' at %L must not be "
2774 "an array of zero size",
2775 args_sym
->name
, sym
->name
,
2776 &(args
->expr
->where
));
2782 /* A non-allocatable target variable with C
2783 interoperable type and type parameters must be
2785 if (args_sym
&& args_sym
->attr
.dimension
)
2787 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2789 gfc_error ("Assumed-shape array '%s' at %L "
2790 "cannot be an argument to the "
2791 "procedure '%s' because "
2792 "it is not C interoperable",
2794 &(args
->expr
->where
), sym
->name
);
2797 else if (args_sym
->as
->type
== AS_DEFERRED
)
2799 gfc_error ("Deferred-shape array '%s' at %L "
2800 "cannot be an argument to the "
2801 "procedure '%s' because "
2802 "it is not C interoperable",
2804 &(args
->expr
->where
), sym
->name
);
2809 /* Make sure it's not a character string. Arrays of
2810 any type should be ok if the variable is of a C
2811 interoperable type. */
2812 if (arg_ts
->type
== BT_CHARACTER
)
2813 if (arg_ts
->u
.cl
!= NULL
2814 && (arg_ts
->u
.cl
->length
== NULL
2815 || arg_ts
->u
.cl
->length
->expr_type
2818 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2820 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2822 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2823 "at %L must have a length of 1",
2824 args_sym
->name
, sym
->name
,
2825 &(args
->expr
->where
));
2830 else if (arg_attr
.pointer
2831 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2833 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2835 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2836 "associated scalar POINTER", args_sym
->name
,
2837 sym
->name
, &(args
->expr
->where
));
2843 /* The parameter is not required to be C interoperable. If it
2844 is not C interoperable, it must be a nonpolymorphic scalar
2845 with no length type parameters. It still must have either
2846 the pointer or target attribute, and it can be
2847 allocatable (but must be allocated when c_loc is called). */
2848 if (args
->expr
->rank
!= 0
2849 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2851 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2852 "scalar", args_sym
->name
, sym
->name
,
2853 &(args
->expr
->where
));
2856 else if (arg_ts
->type
== BT_CHARACTER
2857 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2859 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2860 "%L must have a length of 1",
2861 args_sym
->name
, sym
->name
,
2862 &(args
->expr
->where
));
2865 else if (arg_ts
->type
== BT_CLASS
)
2867 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2868 "polymorphic", args_sym
->name
, sym
->name
,
2869 &(args
->expr
->where
));
2874 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2876 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2878 /* TODO: Update this error message to allow for procedure
2879 pointers once they are implemented. */
2880 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2882 args_sym
->name
, sym
->name
,
2883 &(args
->expr
->where
));
2886 else if (args_sym
->attr
.is_bind_c
!= 1)
2888 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2890 args_sym
->name
, sym
->name
,
2891 &(args
->expr
->where
));
2896 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2901 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2902 "iso_c_binding function: '%s'!\n", sym
->name
);
2909 /* Resolve a function call, which means resolving the arguments, then figuring
2910 out which entity the name refers to. */
2913 resolve_function (gfc_expr
*expr
)
2915 gfc_actual_arglist
*arg
;
2920 procedure_type p
= PROC_INTRINSIC
;
2921 bool no_formal_args
;
2925 sym
= expr
->symtree
->n
.sym
;
2927 /* If this is a procedure pointer component, it has already been resolved. */
2928 if (gfc_is_proc_ptr_comp (expr
, NULL
))
2931 if (sym
&& sym
->attr
.intrinsic
2932 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
2935 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2937 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2941 /* If this ia a deferred TBP with an abstract interface (which may
2942 of course be referenced), expr->value.function.esym will be set. */
2943 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2945 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2946 sym
->name
, &expr
->where
);
2950 /* Switch off assumed size checking and do this again for certain kinds
2951 of procedure, once the procedure itself is resolved. */
2952 need_full_assumed_size
++;
2954 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2955 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2957 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2958 inquiry_argument
= true;
2959 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
2961 if (resolve_actual_arglist (expr
->value
.function
.actual
,
2962 p
, no_formal_args
) == FAILURE
)
2964 inquiry_argument
= false;
2968 inquiry_argument
= false;
2970 /* Need to setup the call to the correct c_associated, depending on
2971 the number of cptrs to user gives to compare. */
2972 if (sym
&& sym
->attr
.is_iso_c
== 1)
2974 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2978 /* Get the symtree for the new symbol (resolved func).
2979 the old one will be freed later, when it's no longer used. */
2980 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
2983 /* Resume assumed_size checking. */
2984 need_full_assumed_size
--;
2986 /* If the procedure is external, check for usage. */
2987 if (sym
&& is_external_proc (sym
))
2988 resolve_global_procedure (sym
, &expr
->where
,
2989 &expr
->value
.function
.actual
, 0);
2991 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2993 && sym
->ts
.u
.cl
->length
== NULL
2995 && !sym
->ts
.deferred
2996 && expr
->value
.function
.esym
== NULL
2997 && !sym
->attr
.contained
)
2999 /* Internal procedures are taken care of in resolve_contained_fntype. */
3000 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3001 "be used at %L since it is not a dummy argument",
3002 sym
->name
, &expr
->where
);
3006 /* See if function is already resolved. */
3008 if (expr
->value
.function
.name
!= NULL
)
3010 if (expr
->ts
.type
== BT_UNKNOWN
)
3016 /* Apply the rules of section 14.1.2. */
3018 switch (procedure_kind (sym
))
3021 t
= resolve_generic_f (expr
);
3024 case PTYPE_SPECIFIC
:
3025 t
= resolve_specific_f (expr
);
3029 t
= resolve_unknown_f (expr
);
3033 gfc_internal_error ("resolve_function(): bad function type");
3037 /* If the expression is still a function (it might have simplified),
3038 then we check to see if we are calling an elemental function. */
3040 if (expr
->expr_type
!= EXPR_FUNCTION
)
3043 temp
= need_full_assumed_size
;
3044 need_full_assumed_size
= 0;
3046 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3049 if (omp_workshare_flag
3050 && expr
->value
.function
.esym
3051 && ! gfc_elemental (expr
->value
.function
.esym
))
3053 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3054 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3059 #define GENERIC_ID expr->value.function.isym->id
3060 else if (expr
->value
.function
.actual
!= NULL
3061 && expr
->value
.function
.isym
!= NULL
3062 && GENERIC_ID
!= GFC_ISYM_LBOUND
3063 && GENERIC_ID
!= GFC_ISYM_LEN
3064 && GENERIC_ID
!= GFC_ISYM_LOC
3065 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3067 /* Array intrinsics must also have the last upper bound of an
3068 assumed size array argument. UBOUND and SIZE have to be
3069 excluded from the check if the second argument is anything
3072 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3074 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3075 && arg
->next
!= NULL
&& arg
->next
->expr
)
3077 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3080 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3083 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3088 if (arg
->expr
!= NULL
3089 && arg
->expr
->rank
> 0
3090 && resolve_assumed_size_actual (arg
->expr
))
3096 need_full_assumed_size
= temp
;
3099 if (!pure_function (expr
, &name
) && name
)
3103 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3104 "FORALL %s", name
, &expr
->where
,
3105 forall_flag
== 2 ? "mask" : "block");
3108 else if (gfc_pure (NULL
))
3110 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3111 "procedure within a PURE procedure", name
, &expr
->where
);
3116 if (!pure_function (expr
, &name
) && name
&& gfc_implicit_pure (NULL
))
3117 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3119 /* Functions without the RECURSIVE attribution are not allowed to
3120 * call themselves. */
3121 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3124 esym
= expr
->value
.function
.esym
;
3126 if (is_illegal_recursion (esym
, gfc_current_ns
))
3128 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3129 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3130 " function '%s' is not RECURSIVE",
3131 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3133 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3134 " is not RECURSIVE", esym
->name
, &expr
->where
);
3140 /* Character lengths of use associated functions may contains references to
3141 symbols not referenced from the current program unit otherwise. Make sure
3142 those symbols are marked as referenced. */
3144 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3145 && expr
->value
.function
.esym
->attr
.use_assoc
)
3147 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3150 /* Make sure that the expression has a typespec that works. */
3151 if (expr
->ts
.type
== BT_UNKNOWN
)
3153 if (expr
->symtree
->n
.sym
->result
3154 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3155 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3156 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3163 /************* Subroutine resolution *************/
3166 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3172 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3173 sym
->name
, &c
->loc
);
3174 else if (gfc_pure (NULL
))
3175 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3181 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3185 if (sym
->attr
.generic
)
3187 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3190 c
->resolved_sym
= s
;
3191 pure_subroutine (c
, s
);
3195 /* TODO: Need to search for elemental references in generic interface. */
3198 if (sym
->attr
.intrinsic
)
3199 return gfc_intrinsic_sub_interface (c
, 0);
3206 resolve_generic_s (gfc_code
*c
)
3211 sym
= c
->symtree
->n
.sym
;
3215 m
= resolve_generic_s0 (c
, sym
);
3218 else if (m
== MATCH_ERROR
)
3222 if (sym
->ns
->parent
== NULL
)
3224 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3228 if (!generic_sym (sym
))
3232 /* Last ditch attempt. See if the reference is to an intrinsic
3233 that possesses a matching interface. 14.1.2.4 */
3234 sym
= c
->symtree
->n
.sym
;
3236 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3238 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3239 sym
->name
, &c
->loc
);
3243 m
= gfc_intrinsic_sub_interface (c
, 0);
3247 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3248 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3254 /* Set the name and binding label of the subroutine symbol in the call
3255 expression represented by 'c' to include the type and kind of the
3256 second parameter. This function is for resolving the appropriate
3257 version of c_f_pointer() and c_f_procpointer(). For example, a
3258 call to c_f_pointer() for a default integer pointer could have a
3259 name of c_f_pointer_i4. If no second arg exists, which is an error
3260 for these two functions, it defaults to the generic symbol's name
3261 and binding label. */
3264 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3265 char *name
, char *binding_label
)
3267 gfc_expr
*arg
= NULL
;
3271 /* The second arg of c_f_pointer and c_f_procpointer determines
3272 the type and kind for the procedure name. */
3273 arg
= c
->ext
.actual
->next
->expr
;
3277 /* Set up the name to have the given symbol's name,
3278 plus the type and kind. */
3279 /* a derived type is marked with the type letter 'u' */
3280 if (arg
->ts
.type
== BT_DERIVED
)
3283 kind
= 0; /* set the kind as 0 for now */
3287 type
= gfc_type_letter (arg
->ts
.type
);
3288 kind
= arg
->ts
.kind
;
3291 if (arg
->ts
.type
== BT_CHARACTER
)
3292 /* Kind info for character strings not needed. */
3295 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3296 /* Set up the binding label as the given symbol's label plus
3297 the type and kind. */
3298 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
3302 /* If the second arg is missing, set the name and label as
3303 was, cause it should at least be found, and the missing
3304 arg error will be caught by compare_parameters(). */
3305 sprintf (name
, "%s", sym
->name
);
3306 sprintf (binding_label
, "%s", sym
->binding_label
);
3313 /* Resolve a generic version of the iso_c_binding procedure given
3314 (sym) to the specific one based on the type and kind of the
3315 argument(s). Currently, this function resolves c_f_pointer() and
3316 c_f_procpointer based on the type and kind of the second argument
3317 (FPTR). Other iso_c_binding procedures aren't specially handled.
3318 Upon successfully exiting, c->resolved_sym will hold the resolved
3319 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3323 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3325 gfc_symbol
*new_sym
;
3326 /* this is fine, since we know the names won't use the max */
3327 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3328 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
3329 /* default to success; will override if find error */
3330 match m
= MATCH_YES
;
3332 /* Make sure the actual arguments are in the necessary order (based on the
3333 formal args) before resolving. */
3334 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3336 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3337 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3339 set_name_and_label (c
, sym
, name
, binding_label
);
3341 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3343 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3345 /* Make sure we got a third arg if the second arg has non-zero
3346 rank. We must also check that the type and rank are
3347 correct since we short-circuit this check in
3348 gfc_procedure_use() (called above to sort actual args). */
3349 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3351 if(c
->ext
.actual
->next
->next
== NULL
3352 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3355 gfc_error ("Missing SHAPE parameter for call to %s "
3356 "at %L", sym
->name
, &(c
->loc
));
3358 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3360 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3363 gfc_error ("SHAPE parameter for call to %s at %L must "
3364 "be a rank 1 INTEGER array", sym
->name
,
3371 if (m
!= MATCH_ERROR
)
3373 /* the 1 means to add the optional arg to formal list */
3374 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3376 /* for error reporting, say it's declared where the original was */
3377 new_sym
->declared_at
= sym
->declared_at
;
3382 /* no differences for c_loc or c_funloc */
3386 /* set the resolved symbol */
3387 if (m
!= MATCH_ERROR
)
3388 c
->resolved_sym
= new_sym
;
3390 c
->resolved_sym
= sym
;
3396 /* Resolve a subroutine call known to be specific. */
3399 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3403 if(sym
->attr
.is_iso_c
)
3405 m
= gfc_iso_c_sub_interface (c
,sym
);
3409 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3411 if (sym
->attr
.dummy
)
3413 sym
->attr
.proc
= PROC_DUMMY
;
3417 sym
->attr
.proc
= PROC_EXTERNAL
;
3421 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3424 if (sym
->attr
.intrinsic
)
3426 m
= gfc_intrinsic_sub_interface (c
, 1);
3430 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3431 "with an intrinsic", sym
->name
, &c
->loc
);
3439 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3441 c
->resolved_sym
= sym
;
3442 pure_subroutine (c
, sym
);
3449 resolve_specific_s (gfc_code
*c
)
3454 sym
= c
->symtree
->n
.sym
;
3458 m
= resolve_specific_s0 (c
, sym
);
3461 if (m
== MATCH_ERROR
)
3464 if (sym
->ns
->parent
== NULL
)
3467 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3473 sym
= c
->symtree
->n
.sym
;
3474 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3475 sym
->name
, &c
->loc
);
3481 /* Resolve a subroutine call not known to be generic nor specific. */
3484 resolve_unknown_s (gfc_code
*c
)
3488 sym
= c
->symtree
->n
.sym
;
3490 if (sym
->attr
.dummy
)
3492 sym
->attr
.proc
= PROC_DUMMY
;
3496 /* See if we have an intrinsic function reference. */
3498 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3500 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3505 /* The reference is to an external name. */
3508 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3510 c
->resolved_sym
= sym
;
3512 pure_subroutine (c
, sym
);
3518 /* Resolve a subroutine call. Although it was tempting to use the same code
3519 for functions, subroutines and functions are stored differently and this
3520 makes things awkward. */
3523 resolve_call (gfc_code
*c
)
3526 procedure_type ptype
= PROC_INTRINSIC
;
3527 gfc_symbol
*csym
, *sym
;
3528 bool no_formal_args
;
3530 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3532 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3534 gfc_error ("'%s' at %L has a type, which is not consistent with "
3535 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3539 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3542 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3543 sym
= st
? st
->n
.sym
: NULL
;
3544 if (sym
&& csym
!= sym
3545 && sym
->ns
== gfc_current_ns
3546 && sym
->attr
.flavor
== FL_PROCEDURE
3547 && sym
->attr
.contained
)
3550 if (csym
->attr
.generic
)
3551 c
->symtree
->n
.sym
= sym
;
3554 csym
= c
->symtree
->n
.sym
;
3558 /* If this ia a deferred TBP with an abstract interface
3559 (which may of course be referenced), c->expr1 will be set. */
3560 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3562 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3563 csym
->name
, &c
->loc
);
3567 /* Subroutines without the RECURSIVE attribution are not allowed to
3568 * call themselves. */
3569 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3571 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3572 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3573 " subroutine '%s' is not RECURSIVE",
3574 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3576 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3577 " is not RECURSIVE", csym
->name
, &c
->loc
);
3582 /* Switch off assumed size checking and do this again for certain kinds
3583 of procedure, once the procedure itself is resolved. */
3584 need_full_assumed_size
++;
3587 ptype
= csym
->attr
.proc
;
3589 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3590 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3591 no_formal_args
) == FAILURE
)
3594 /* Resume assumed_size checking. */
3595 need_full_assumed_size
--;
3597 /* If external, check for usage. */
3598 if (csym
&& is_external_proc (csym
))
3599 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3602 if (c
->resolved_sym
== NULL
)
3604 c
->resolved_isym
= NULL
;
3605 switch (procedure_kind (csym
))
3608 t
= resolve_generic_s (c
);
3611 case PTYPE_SPECIFIC
:
3612 t
= resolve_specific_s (c
);
3616 t
= resolve_unknown_s (c
);
3620 gfc_internal_error ("resolve_subroutine(): bad function type");
3624 /* Some checks of elemental subroutine actual arguments. */
3625 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3632 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3633 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3634 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3635 if their shapes do not match. If either op1->shape or op2->shape is
3636 NULL, return SUCCESS. */
3639 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3646 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3648 for (i
= 0; i
< op1
->rank
; i
++)
3650 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3652 gfc_error ("Shapes for operands at %L and %L are not conformable",
3653 &op1
->where
, &op2
->where
);
3664 /* Resolve an operator expression node. This can involve replacing the
3665 operation with a user defined function call. */
3668 resolve_operator (gfc_expr
*e
)
3670 gfc_expr
*op1
, *op2
;
3672 bool dual_locus_error
;
3675 /* Resolve all subnodes-- give them types. */
3677 switch (e
->value
.op
.op
)
3680 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3683 /* Fall through... */
3686 case INTRINSIC_UPLUS
:
3687 case INTRINSIC_UMINUS
:
3688 case INTRINSIC_PARENTHESES
:
3689 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3694 /* Typecheck the new node. */
3696 op1
= e
->value
.op
.op1
;
3697 op2
= e
->value
.op
.op2
;
3698 dual_locus_error
= false;
3700 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3701 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3703 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3707 switch (e
->value
.op
.op
)
3709 case INTRINSIC_UPLUS
:
3710 case INTRINSIC_UMINUS
:
3711 if (op1
->ts
.type
== BT_INTEGER
3712 || op1
->ts
.type
== BT_REAL
3713 || op1
->ts
.type
== BT_COMPLEX
)
3719 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3720 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3723 case INTRINSIC_PLUS
:
3724 case INTRINSIC_MINUS
:
3725 case INTRINSIC_TIMES
:
3726 case INTRINSIC_DIVIDE
:
3727 case INTRINSIC_POWER
:
3728 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3730 gfc_type_convert_binary (e
, 1);
3735 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3736 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3737 gfc_typename (&op2
->ts
));
3740 case INTRINSIC_CONCAT
:
3741 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3742 && op1
->ts
.kind
== op2
->ts
.kind
)
3744 e
->ts
.type
= BT_CHARACTER
;
3745 e
->ts
.kind
= op1
->ts
.kind
;
3750 _("Operands of string concatenation operator at %%L are %s/%s"),
3751 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3757 case INTRINSIC_NEQV
:
3758 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3760 e
->ts
.type
= BT_LOGICAL
;
3761 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3762 if (op1
->ts
.kind
< e
->ts
.kind
)
3763 gfc_convert_type (op1
, &e
->ts
, 2);
3764 else if (op2
->ts
.kind
< e
->ts
.kind
)
3765 gfc_convert_type (op2
, &e
->ts
, 2);
3769 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3770 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3771 gfc_typename (&op2
->ts
));
3776 if (op1
->ts
.type
== BT_LOGICAL
)
3778 e
->ts
.type
= BT_LOGICAL
;
3779 e
->ts
.kind
= op1
->ts
.kind
;
3783 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3784 gfc_typename (&op1
->ts
));
3788 case INTRINSIC_GT_OS
:
3790 case INTRINSIC_GE_OS
:
3792 case INTRINSIC_LT_OS
:
3794 case INTRINSIC_LE_OS
:
3795 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3797 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3801 /* Fall through... */
3804 case INTRINSIC_EQ_OS
:
3806 case INTRINSIC_NE_OS
:
3807 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3808 && op1
->ts
.kind
== op2
->ts
.kind
)
3810 e
->ts
.type
= BT_LOGICAL
;
3811 e
->ts
.kind
= gfc_default_logical_kind
;
3815 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3817 gfc_type_convert_binary (e
, 1);
3819 e
->ts
.type
= BT_LOGICAL
;
3820 e
->ts
.kind
= gfc_default_logical_kind
;
3824 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3826 _("Logicals at %%L must be compared with %s instead of %s"),
3827 (e
->value
.op
.op
== INTRINSIC_EQ
3828 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3829 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3832 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3833 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3834 gfc_typename (&op2
->ts
));
3838 case INTRINSIC_USER
:
3839 if (e
->value
.op
.uop
->op
== NULL
)
3840 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3841 else if (op2
== NULL
)
3842 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3843 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3846 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3847 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3848 gfc_typename (&op2
->ts
));
3849 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3854 case INTRINSIC_PARENTHESES
:
3856 if (e
->ts
.type
== BT_CHARACTER
)
3857 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3861 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3864 /* Deal with arrayness of an operand through an operator. */
3868 switch (e
->value
.op
.op
)
3870 case INTRINSIC_PLUS
:
3871 case INTRINSIC_MINUS
:
3872 case INTRINSIC_TIMES
:
3873 case INTRINSIC_DIVIDE
:
3874 case INTRINSIC_POWER
:
3875 case INTRINSIC_CONCAT
:
3879 case INTRINSIC_NEQV
:
3881 case INTRINSIC_EQ_OS
:
3883 case INTRINSIC_NE_OS
:
3885 case INTRINSIC_GT_OS
:
3887 case INTRINSIC_GE_OS
:
3889 case INTRINSIC_LT_OS
:
3891 case INTRINSIC_LE_OS
:
3893 if (op1
->rank
== 0 && op2
->rank
== 0)
3896 if (op1
->rank
== 0 && op2
->rank
!= 0)
3898 e
->rank
= op2
->rank
;
3900 if (e
->shape
== NULL
)
3901 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3904 if (op1
->rank
!= 0 && op2
->rank
== 0)
3906 e
->rank
= op1
->rank
;
3908 if (e
->shape
== NULL
)
3909 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3912 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3914 if (op1
->rank
== op2
->rank
)
3916 e
->rank
= op1
->rank
;
3917 if (e
->shape
== NULL
)
3919 t
= compare_shapes (op1
, op2
);
3923 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3928 /* Allow higher level expressions to work. */
3931 /* Try user-defined operators, and otherwise throw an error. */
3932 dual_locus_error
= true;
3934 _("Inconsistent ranks for operator at %%L and %%L"));
3941 case INTRINSIC_PARENTHESES
:
3943 case INTRINSIC_UPLUS
:
3944 case INTRINSIC_UMINUS
:
3945 /* Simply copy arrayness attribute */
3946 e
->rank
= op1
->rank
;
3948 if (e
->shape
== NULL
)
3949 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3957 /* Attempt to simplify the expression. */
3960 t
= gfc_simplify_expr (e
, 0);
3961 /* Some calls do not succeed in simplification and return FAILURE
3962 even though there is no error; e.g. variable references to
3963 PARAMETER arrays. */
3964 if (!gfc_is_constant_expr (e
))
3973 if (gfc_extend_expr (e
, &real_error
) == SUCCESS
)
3980 if (dual_locus_error
)
3981 gfc_error (msg
, &op1
->where
, &op2
->where
);
3983 gfc_error (msg
, &e
->where
);
3989 /************** Array resolution subroutines **************/
3992 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3995 /* Compare two integer expressions. */
3998 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4002 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4003 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4006 /* If either of the types isn't INTEGER, we must have
4007 raised an error earlier. */
4009 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4012 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4022 /* Compare an integer expression with an integer. */
4025 compare_bound_int (gfc_expr
*a
, int b
)
4029 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4032 if (a
->ts
.type
!= BT_INTEGER
)
4033 gfc_internal_error ("compare_bound_int(): Bad expression");
4035 i
= mpz_cmp_si (a
->value
.integer
, b
);
4045 /* Compare an integer expression with a mpz_t. */
4048 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4052 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4055 if (a
->ts
.type
!= BT_INTEGER
)
4056 gfc_internal_error ("compare_bound_int(): Bad expression");
4058 i
= mpz_cmp (a
->value
.integer
, b
);
4068 /* Compute the last value of a sequence given by a triplet.
4069 Return 0 if it wasn't able to compute the last value, or if the
4070 sequence if empty, and 1 otherwise. */
4073 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4074 gfc_expr
*stride
, mpz_t last
)
4078 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4079 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4080 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4083 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4084 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4087 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4089 if (compare_bound (start
, end
) == CMP_GT
)
4091 mpz_set (last
, end
->value
.integer
);
4095 if (compare_bound_int (stride
, 0) == CMP_GT
)
4097 /* Stride is positive */
4098 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4103 /* Stride is negative */
4104 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4109 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4110 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4111 mpz_sub (last
, end
->value
.integer
, rem
);
4118 /* Compare a single dimension of an array reference to the array
4122 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4126 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4128 gcc_assert (ar
->stride
[i
] == NULL
);
4129 /* This implies [*] as [*:] and [*:3] are not possible. */
4130 if (ar
->start
[i
] == NULL
)
4132 gcc_assert (ar
->end
[i
] == NULL
);
4137 /* Given start, end and stride values, calculate the minimum and
4138 maximum referenced indexes. */
4140 switch (ar
->dimen_type
[i
])
4147 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4150 gfc_warning ("Array reference at %L is out of bounds "
4151 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4152 mpz_get_si (ar
->start
[i
]->value
.integer
),
4153 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4155 gfc_warning ("Array reference at %L is out of bounds "
4156 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4157 mpz_get_si (ar
->start
[i
]->value
.integer
),
4158 mpz_get_si (as
->lower
[i
]->value
.integer
),
4162 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4165 gfc_warning ("Array reference at %L is out of bounds "
4166 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4167 mpz_get_si (ar
->start
[i
]->value
.integer
),
4168 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4170 gfc_warning ("Array reference at %L is out of bounds "
4171 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4172 mpz_get_si (ar
->start
[i
]->value
.integer
),
4173 mpz_get_si (as
->upper
[i
]->value
.integer
),
4182 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4183 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4185 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4187 /* Check for zero stride, which is not allowed. */
4188 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4190 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4194 /* if start == len || (stride > 0 && start < len)
4195 || (stride < 0 && start > len),
4196 then the array section contains at least one element. In this
4197 case, there is an out-of-bounds access if
4198 (start < lower || start > upper). */
4199 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4200 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4201 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4202 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4203 && comp_start_end
== CMP_GT
))
4205 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4207 gfc_warning ("Lower array reference at %L is out of bounds "
4208 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4209 mpz_get_si (AR_START
->value
.integer
),
4210 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4213 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4215 gfc_warning ("Lower array reference at %L is out of bounds "
4216 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4217 mpz_get_si (AR_START
->value
.integer
),
4218 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4223 /* If we can compute the highest index of the array section,
4224 then it also has to be between lower and upper. */
4225 mpz_init (last_value
);
4226 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4229 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4231 gfc_warning ("Upper array reference at %L is out of bounds "
4232 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4233 mpz_get_si (last_value
),
4234 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4235 mpz_clear (last_value
);
4238 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4240 gfc_warning ("Upper array reference at %L is out of bounds "
4241 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4242 mpz_get_si (last_value
),
4243 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4244 mpz_clear (last_value
);
4248 mpz_clear (last_value
);
4256 gfc_internal_error ("check_dimension(): Bad array reference");
4263 /* Compare an array reference with an array specification. */
4266 compare_spec_to_ref (gfc_array_ref
*ar
)
4273 /* TODO: Full array sections are only allowed as actual parameters. */
4274 if (as
->type
== AS_ASSUMED_SIZE
4275 && (/*ar->type == AR_FULL
4276 ||*/ (ar
->type
== AR_SECTION
4277 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4279 gfc_error ("Rightmost upper bound of assumed size array section "
4280 "not specified at %L", &ar
->where
);
4284 if (ar
->type
== AR_FULL
)
4287 if (as
->rank
!= ar
->dimen
)
4289 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4290 &ar
->where
, ar
->dimen
, as
->rank
);
4294 /* ar->codimen == 0 is a local array. */
4295 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4297 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4298 &ar
->where
, ar
->codimen
, as
->corank
);
4302 for (i
= 0; i
< as
->rank
; i
++)
4303 if (check_dimension (i
, ar
, as
) == FAILURE
)
4306 /* Local access has no coarray spec. */
4307 if (ar
->codimen
!= 0)
4308 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4310 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
)
4312 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4313 i
+ 1 - as
->rank
, &ar
->where
);
4316 if (check_dimension (i
, ar
, as
) == FAILURE
)
4324 /* Resolve one part of an array index. */
4327 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4328 int force_index_integer_kind
)
4335 if (gfc_resolve_expr (index
) == FAILURE
)
4338 if (check_scalar
&& index
->rank
!= 0)
4340 gfc_error ("Array index at %L must be scalar", &index
->where
);
4344 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4346 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4347 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4351 if (index
->ts
.type
== BT_REAL
)
4352 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
4353 &index
->where
) == FAILURE
)
4356 if ((index
->ts
.kind
!= gfc_index_integer_kind
4357 && force_index_integer_kind
)
4358 || index
->ts
.type
!= BT_INTEGER
)
4361 ts
.type
= BT_INTEGER
;
4362 ts
.kind
= gfc_index_integer_kind
;
4364 gfc_convert_type_warn (index
, &ts
, 2, 0);
4370 /* Resolve one part of an array index. */
4373 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4375 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4378 /* Resolve a dim argument to an intrinsic function. */
4381 gfc_resolve_dim_arg (gfc_expr
*dim
)
4386 if (gfc_resolve_expr (dim
) == FAILURE
)
4391 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4396 if (dim
->ts
.type
!= BT_INTEGER
)
4398 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4402 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4407 ts
.type
= BT_INTEGER
;
4408 ts
.kind
= gfc_index_integer_kind
;
4410 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4416 /* Given an expression that contains array references, update those array
4417 references to point to the right array specifications. While this is
4418 filled in during matching, this information is difficult to save and load
4419 in a module, so we take care of it here.
4421 The idea here is that the original array reference comes from the
4422 base symbol. We traverse the list of reference structures, setting
4423 the stored reference to references. Component references can
4424 provide an additional array specification. */
4427 find_array_spec (gfc_expr
*e
)
4431 gfc_symbol
*derived
;
4434 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4435 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4437 as
= e
->symtree
->n
.sym
->as
;
4440 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4445 gfc_internal_error ("find_array_spec(): Missing spec");
4452 if (derived
== NULL
)
4453 derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
4455 if (derived
->attr
.is_class
)
4456 derived
= derived
->components
->ts
.u
.derived
;
4458 c
= derived
->components
;
4460 for (; c
; c
= c
->next
)
4461 if (c
== ref
->u
.c
.component
)
4463 /* Track the sequence of component references. */
4464 if (c
->ts
.type
== BT_DERIVED
)
4465 derived
= c
->ts
.u
.derived
;
4470 gfc_internal_error ("find_array_spec(): Component not found");
4472 if (c
->attr
.dimension
)
4475 gfc_internal_error ("find_array_spec(): unused as(1)");
4486 gfc_internal_error ("find_array_spec(): unused as(2)");
4490 /* Resolve an array reference. */
4493 resolve_array_ref (gfc_array_ref
*ar
)
4495 int i
, check_scalar
;
4498 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4500 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4502 /* Do not force gfc_index_integer_kind for the start. We can
4503 do fine with any integer kind. This avoids temporary arrays
4504 created for indexing with a vector. */
4505 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4507 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4509 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4514 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4518 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4522 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4523 if (e
->expr_type
== EXPR_VARIABLE
4524 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4525 ar
->start
[i
] = gfc_get_parentheses (e
);
4529 gfc_error ("Array index at %L is an array of rank %d",
4530 &ar
->c_where
[i
], e
->rank
);
4534 /* Fill in the upper bound, which may be lower than the
4535 specified one for something like a(2:10:5), which is
4536 identical to a(2:7:5). Only relevant for strides not equal
4538 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4539 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4540 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0)
4544 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4546 if (ar
->end
[i
] == NULL
)
4549 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4551 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4553 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4554 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4556 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4567 if (ar
->type
== AR_FULL
&& ar
->as
->rank
== 0)
4568 ar
->type
= AR_ELEMENT
;
4570 /* If the reference type is unknown, figure out what kind it is. */
4572 if (ar
->type
== AR_UNKNOWN
)
4574 ar
->type
= AR_ELEMENT
;
4575 for (i
= 0; i
< ar
->dimen
; i
++)
4576 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4577 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4579 ar
->type
= AR_SECTION
;
4584 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4592 resolve_substring (gfc_ref
*ref
)
4594 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4596 if (ref
->u
.ss
.start
!= NULL
)
4598 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4601 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4603 gfc_error ("Substring start index at %L must be of type INTEGER",
4604 &ref
->u
.ss
.start
->where
);
4608 if (ref
->u
.ss
.start
->rank
!= 0)
4610 gfc_error ("Substring start index at %L must be scalar",
4611 &ref
->u
.ss
.start
->where
);
4615 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4616 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4617 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4619 gfc_error ("Substring start index at %L is less than one",
4620 &ref
->u
.ss
.start
->where
);
4625 if (ref
->u
.ss
.end
!= NULL
)
4627 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4630 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4632 gfc_error ("Substring end index at %L must be of type INTEGER",
4633 &ref
->u
.ss
.end
->where
);
4637 if (ref
->u
.ss
.end
->rank
!= 0)
4639 gfc_error ("Substring end index at %L must be scalar",
4640 &ref
->u
.ss
.end
->where
);
4644 if (ref
->u
.ss
.length
!= NULL
4645 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4646 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4647 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4649 gfc_error ("Substring end index at %L exceeds the string length",
4650 &ref
->u
.ss
.start
->where
);
4654 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4655 gfc_integer_kinds
[k
].huge
) == CMP_GT
4656 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4657 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4659 gfc_error ("Substring end index at %L is too large",
4660 &ref
->u
.ss
.end
->where
);
4669 /* This function supplies missing substring charlens. */
4672 gfc_resolve_substring_charlen (gfc_expr
*e
)
4675 gfc_expr
*start
, *end
;
4677 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4678 if (char_ref
->type
== REF_SUBSTRING
)
4684 gcc_assert (char_ref
->next
== NULL
);
4688 if (e
->ts
.u
.cl
->length
)
4689 gfc_free_expr (e
->ts
.u
.cl
->length
);
4690 else if (e
->expr_type
== EXPR_VARIABLE
4691 && e
->symtree
->n
.sym
->attr
.dummy
)
4695 e
->ts
.type
= BT_CHARACTER
;
4696 e
->ts
.kind
= gfc_default_character_kind
;
4699 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4701 if (char_ref
->u
.ss
.start
)
4702 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4704 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4706 if (char_ref
->u
.ss
.end
)
4707 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4708 else if (e
->expr_type
== EXPR_VARIABLE
)
4709 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4716 /* Length = (end - start +1). */
4717 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4718 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4719 gfc_get_int_expr (gfc_default_integer_kind
,
4722 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4723 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4725 /* Make sure that the length is simplified. */
4726 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4727 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4731 /* Resolve subtype references. */
4734 resolve_ref (gfc_expr
*expr
)
4736 int current_part_dimension
, n_components
, seen_part_dimension
;
4739 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4740 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4742 find_array_spec (expr
);
4746 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4750 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4758 resolve_substring (ref
);
4762 /* Check constraints on part references. */
4764 current_part_dimension
= 0;
4765 seen_part_dimension
= 0;
4768 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4773 switch (ref
->u
.ar
.type
)
4776 /* Coarray scalar. */
4777 if (ref
->u
.ar
.as
->rank
== 0)
4779 current_part_dimension
= 0;
4784 current_part_dimension
= 1;
4788 current_part_dimension
= 0;
4792 gfc_internal_error ("resolve_ref(): Bad array reference");
4798 if (current_part_dimension
|| seen_part_dimension
)
4801 if (ref
->u
.c
.component
->attr
.pointer
4802 || ref
->u
.c
.component
->attr
.proc_pointer
)
4804 gfc_error ("Component to the right of a part reference "
4805 "with nonzero rank must not have the POINTER "
4806 "attribute at %L", &expr
->where
);
4809 else if (ref
->u
.c
.component
->attr
.allocatable
)
4811 gfc_error ("Component to the right of a part reference "
4812 "with nonzero rank must not have the ALLOCATABLE "
4813 "attribute at %L", &expr
->where
);
4825 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4826 || ref
->next
== NULL
)
4827 && current_part_dimension
4828 && seen_part_dimension
)
4830 gfc_error ("Two or more part references with nonzero rank must "
4831 "not be specified at %L", &expr
->where
);
4835 if (ref
->type
== REF_COMPONENT
)
4837 if (current_part_dimension
)
4838 seen_part_dimension
= 1;
4840 /* reset to make sure */
4841 current_part_dimension
= 0;
4849 /* Given an expression, determine its shape. This is easier than it sounds.
4850 Leaves the shape array NULL if it is not possible to determine the shape. */
4853 expression_shape (gfc_expr
*e
)
4855 mpz_t array
[GFC_MAX_DIMENSIONS
];
4858 if (e
->rank
== 0 || e
->shape
!= NULL
)
4861 for (i
= 0; i
< e
->rank
; i
++)
4862 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4865 e
->shape
= gfc_get_shape (e
->rank
);
4867 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4872 for (i
--; i
>= 0; i
--)
4873 mpz_clear (array
[i
]);
4877 /* Given a variable expression node, compute the rank of the expression by
4878 examining the base symbol and any reference structures it may have. */
4881 expression_rank (gfc_expr
*e
)
4886 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4887 could lead to serious confusion... */
4888 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4892 if (e
->expr_type
== EXPR_ARRAY
)
4894 /* Constructors can have a rank different from one via RESHAPE(). */
4896 if (e
->symtree
== NULL
)
4902 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4903 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4909 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4911 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4912 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4913 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4915 if (ref
->type
!= REF_ARRAY
)
4918 if (ref
->u
.ar
.type
== AR_FULL
)
4920 rank
= ref
->u
.ar
.as
->rank
;
4924 if (ref
->u
.ar
.type
== AR_SECTION
)
4926 /* Figure out the rank of the section. */
4928 gfc_internal_error ("expression_rank(): Two array specs");
4930 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4931 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4932 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4942 expression_shape (e
);
4946 /* Resolve a variable expression. */
4949 resolve_variable (gfc_expr
*e
)
4956 if (e
->symtree
== NULL
)
4958 sym
= e
->symtree
->n
.sym
;
4960 /* If this is an associate-name, it may be parsed with an array reference
4961 in error even though the target is scalar. Fail directly in this case. */
4962 if (sym
->assoc
&& !sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4965 /* On the other hand, the parser may not have known this is an array;
4966 in this case, we have to add a FULL reference. */
4967 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4969 e
->ref
= gfc_get_ref ();
4970 e
->ref
->type
= REF_ARRAY
;
4971 e
->ref
->u
.ar
.type
= AR_FULL
;
4972 e
->ref
->u
.ar
.dimen
= 0;
4975 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
4978 if (sym
->attr
.flavor
== FL_PROCEDURE
4979 && (!sym
->attr
.function
4980 || (sym
->attr
.function
&& sym
->result
4981 && sym
->result
->attr
.proc_pointer
4982 && !sym
->result
->attr
.function
)))
4984 e
->ts
.type
= BT_PROCEDURE
;
4985 goto resolve_procedure
;
4988 if (sym
->ts
.type
!= BT_UNKNOWN
)
4989 gfc_variable_attr (e
, &e
->ts
);
4992 /* Must be a simple variable reference. */
4993 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
4998 if (check_assumed_size_reference (sym
, e
))
5001 /* Deal with forward references to entries during resolve_code, to
5002 satisfy, at least partially, 12.5.2.5. */
5003 if (gfc_current_ns
->entries
5004 && current_entry_id
== sym
->entry_id
5007 && cs_base
->current
->op
!= EXEC_ENTRY
)
5009 gfc_entry_list
*entry
;
5010 gfc_formal_arglist
*formal
;
5014 /* If the symbol is a dummy... */
5015 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5017 entry
= gfc_current_ns
->entries
;
5020 /* ...test if the symbol is a parameter of previous entries. */
5021 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5022 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5024 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5028 /* If it has not been seen as a dummy, this is an error. */
5031 if (specification_expr
)
5032 gfc_error ("Variable '%s', used in a specification expression"
5033 ", is referenced at %L before the ENTRY statement "
5034 "in which it is a parameter",
5035 sym
->name
, &cs_base
->current
->loc
);
5037 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5038 "statement in which it is a parameter",
5039 sym
->name
, &cs_base
->current
->loc
);
5044 /* Now do the same check on the specification expressions. */
5045 specification_expr
= 1;
5046 if (sym
->ts
.type
== BT_CHARACTER
5047 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5051 for (n
= 0; n
< sym
->as
->rank
; n
++)
5053 specification_expr
= 1;
5054 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5056 specification_expr
= 1;
5057 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5060 specification_expr
= 0;
5063 /* Update the symbol's entry level. */
5064 sym
->entry_id
= current_entry_id
+ 1;
5067 /* If a symbol has been host_associated mark it. This is used latter,
5068 to identify if aliasing is possible via host association. */
5069 if (sym
->attr
.flavor
== FL_VARIABLE
5070 && gfc_current_ns
->parent
5071 && (gfc_current_ns
->parent
== sym
->ns
5072 || (gfc_current_ns
->parent
->parent
5073 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5074 sym
->attr
.host_assoc
= 1;
5077 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5080 /* F2008, C617 and C1229. */
5081 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5082 && gfc_is_coindexed (e
))
5084 gfc_ref
*ref
, *ref2
= NULL
;
5086 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5088 if (ref
->type
== REF_COMPONENT
)
5090 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5094 for ( ; ref
; ref
= ref
->next
)
5095 if (ref
->type
== REF_COMPONENT
)
5098 /* Expression itself is not coindexed object. */
5099 if (ref
&& e
->ts
.type
== BT_CLASS
)
5101 gfc_error ("Polymorphic subobject of coindexed object at %L",
5106 /* Expression itself is coindexed object. */
5110 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5111 for ( ; c
; c
= c
->next
)
5112 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5114 gfc_error ("Coindexed object with polymorphic allocatable "
5115 "subcomponent at %L", &e
->where
);
5126 /* Checks to see that the correct symbol has been host associated.
5127 The only situation where this arises is that in which a twice
5128 contained function is parsed after the host association is made.
5129 Therefore, on detecting this, change the symbol in the expression
5130 and convert the array reference into an actual arglist if the old
5131 symbol is a variable. */
5133 check_host_association (gfc_expr
*e
)
5135 gfc_symbol
*sym
, *old_sym
;
5139 gfc_actual_arglist
*arg
, *tail
= NULL
;
5140 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5142 /* If the expression is the result of substitution in
5143 interface.c(gfc_extend_expr) because there is no way in
5144 which the host association can be wrong. */
5145 if (e
->symtree
== NULL
5146 || e
->symtree
->n
.sym
== NULL
5147 || e
->user_operator
)
5150 old_sym
= e
->symtree
->n
.sym
;
5152 if (gfc_current_ns
->parent
5153 && old_sym
->ns
!= gfc_current_ns
)
5155 /* Use the 'USE' name so that renamed module symbols are
5156 correctly handled. */
5157 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5159 if (sym
&& old_sym
!= sym
5160 && sym
->ts
.type
== old_sym
->ts
.type
5161 && sym
->attr
.flavor
== FL_PROCEDURE
5162 && sym
->attr
.contained
)
5164 /* Clear the shape, since it might not be valid. */
5165 if (e
->shape
!= NULL
)
5167 for (n
= 0; n
< e
->rank
; n
++)
5168 mpz_clear (e
->shape
[n
]);
5170 gfc_free (e
->shape
);
5173 /* Give the expression the right symtree! */
5174 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5175 gcc_assert (st
!= NULL
);
5177 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5178 || e
->expr_type
== EXPR_FUNCTION
)
5180 /* Original was function so point to the new symbol, since
5181 the actual argument list is already attached to the
5183 e
->value
.function
.esym
= NULL
;
5188 /* Original was variable so convert array references into
5189 an actual arglist. This does not need any checking now
5190 since gfc_resolve_function will take care of it. */
5191 e
->value
.function
.actual
= NULL
;
5192 e
->expr_type
= EXPR_FUNCTION
;
5195 /* Ambiguity will not arise if the array reference is not
5196 the last reference. */
5197 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5198 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5201 gcc_assert (ref
->type
== REF_ARRAY
);
5203 /* Grab the start expressions from the array ref and
5204 copy them into actual arguments. */
5205 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5207 arg
= gfc_get_actual_arglist ();
5208 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5209 if (e
->value
.function
.actual
== NULL
)
5210 tail
= e
->value
.function
.actual
= arg
;
5218 /* Dump the reference list and set the rank. */
5219 gfc_free_ref_list (e
->ref
);
5221 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5224 gfc_resolve_expr (e
);
5228 /* This might have changed! */
5229 return e
->expr_type
== EXPR_FUNCTION
;
5234 gfc_resolve_character_operator (gfc_expr
*e
)
5236 gfc_expr
*op1
= e
->value
.op
.op1
;
5237 gfc_expr
*op2
= e
->value
.op
.op2
;
5238 gfc_expr
*e1
= NULL
;
5239 gfc_expr
*e2
= NULL
;
5241 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5243 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5244 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5245 else if (op1
->expr_type
== EXPR_CONSTANT
)
5246 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5247 op1
->value
.character
.length
);
5249 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5250 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5251 else if (op2
->expr_type
== EXPR_CONSTANT
)
5252 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5253 op2
->value
.character
.length
);
5255 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5260 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5261 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5262 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5263 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5264 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5270 /* Ensure that an character expression has a charlen and, if possible, a
5271 length expression. */
5274 fixup_charlen (gfc_expr
*e
)
5276 /* The cases fall through so that changes in expression type and the need
5277 for multiple fixes are picked up. In all circumstances, a charlen should
5278 be available for the middle end to hang a backend_decl on. */
5279 switch (e
->expr_type
)
5282 gfc_resolve_character_operator (e
);
5285 if (e
->expr_type
== EXPR_ARRAY
)
5286 gfc_resolve_character_array_constructor (e
);
5288 case EXPR_SUBSTRING
:
5289 if (!e
->ts
.u
.cl
&& e
->ref
)
5290 gfc_resolve_substring_charlen (e
);
5294 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5301 /* Update an actual argument to include the passed-object for type-bound
5302 procedures at the right position. */
5304 static gfc_actual_arglist
*
5305 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5308 gcc_assert (argpos
> 0);
5312 gfc_actual_arglist
* result
;
5314 result
= gfc_get_actual_arglist ();
5318 result
->name
= name
;
5324 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5326 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5331 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5334 extract_compcall_passed_object (gfc_expr
* e
)
5338 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5340 if (e
->value
.compcall
.base_object
)
5341 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5344 po
= gfc_get_expr ();
5345 po
->expr_type
= EXPR_VARIABLE
;
5346 po
->symtree
= e
->symtree
;
5347 po
->ref
= gfc_copy_ref (e
->ref
);
5348 po
->where
= e
->where
;
5351 if (gfc_resolve_expr (po
) == FAILURE
)
5358 /* Update the arglist of an EXPR_COMPCALL expression to include the
5362 update_compcall_arglist (gfc_expr
* e
)
5365 gfc_typebound_proc
* tbp
;
5367 tbp
= e
->value
.compcall
.tbp
;
5372 po
= extract_compcall_passed_object (e
);
5376 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5382 gcc_assert (tbp
->pass_arg_num
> 0);
5383 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5391 /* Extract the passed object from a PPC call (a copy of it). */
5394 extract_ppc_passed_object (gfc_expr
*e
)
5399 po
= gfc_get_expr ();
5400 po
->expr_type
= EXPR_VARIABLE
;
5401 po
->symtree
= e
->symtree
;
5402 po
->ref
= gfc_copy_ref (e
->ref
);
5403 po
->where
= e
->where
;
5405 /* Remove PPC reference. */
5407 while ((*ref
)->next
)
5408 ref
= &(*ref
)->next
;
5409 gfc_free_ref_list (*ref
);
5412 if (gfc_resolve_expr (po
) == FAILURE
)
5419 /* Update the actual arglist of a procedure pointer component to include the
5423 update_ppc_arglist (gfc_expr
* e
)
5427 gfc_typebound_proc
* tb
;
5429 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5436 else if (tb
->nopass
)
5439 po
= extract_ppc_passed_object (e
);
5446 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5451 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5453 gfc_error ("Base object for procedure-pointer component call at %L is of"
5454 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5458 gcc_assert (tb
->pass_arg_num
> 0);
5459 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5467 /* Check that the object a TBP is called on is valid, i.e. it must not be
5468 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5471 check_typebound_baseobject (gfc_expr
* e
)
5474 gfc_try return_value
= FAILURE
;
5476 base
= extract_compcall_passed_object (e
);
5480 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5483 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5485 gfc_error ("Base object for type-bound procedure call at %L is of"
5486 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5490 /* F08:C1230. If the procedure called is NOPASS,
5491 the base object must be scalar. */
5492 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
> 0)
5494 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5495 " be scalar", &e
->where
);
5499 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5502 gfc_error ("Non-scalar base object at %L currently not implemented",
5507 return_value
= SUCCESS
;
5510 gfc_free_expr (base
);
5511 return return_value
;
5515 /* Resolve a call to a type-bound procedure, either function or subroutine,
5516 statically from the data in an EXPR_COMPCALL expression. The adapted
5517 arglist and the target-procedure symtree are returned. */
5520 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5521 gfc_actual_arglist
** actual
)
5523 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5524 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5526 /* Update the actual arglist for PASS. */
5527 if (update_compcall_arglist (e
) == FAILURE
)
5530 *actual
= e
->value
.compcall
.actual
;
5531 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5533 gfc_free_ref_list (e
->ref
);
5535 e
->value
.compcall
.actual
= NULL
;
5541 /* Get the ultimate declared type from an expression. In addition,
5542 return the last class/derived type reference and the copy of the
5545 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5548 gfc_symbol
*declared
;
5555 *new_ref
= gfc_copy_ref (e
->ref
);
5557 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5559 if (ref
->type
!= REF_COMPONENT
)
5562 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5563 || ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5565 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5571 if (declared
== NULL
)
5572 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5578 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5579 which of the specific bindings (if any) matches the arglist and transform
5580 the expression into a call of that binding. */
5583 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5585 gfc_typebound_proc
* genproc
;
5586 const char* genname
;
5588 gfc_symbol
*derived
;
5590 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5591 genname
= e
->value
.compcall
.name
;
5592 genproc
= e
->value
.compcall
.tbp
;
5594 if (!genproc
->is_generic
)
5597 /* Try the bindings on this type and in the inheritance hierarchy. */
5598 for (; genproc
; genproc
= genproc
->overridden
)
5602 gcc_assert (genproc
->is_generic
);
5603 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5606 gfc_actual_arglist
* args
;
5609 gcc_assert (g
->specific
);
5611 if (g
->specific
->error
)
5614 target
= g
->specific
->u
.specific
->n
.sym
;
5616 /* Get the right arglist by handling PASS/NOPASS. */
5617 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5618 if (!g
->specific
->nopass
)
5621 po
= extract_compcall_passed_object (e
);
5625 gcc_assert (g
->specific
->pass_arg_num
> 0);
5626 gcc_assert (!g
->specific
->error
);
5627 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5628 g
->specific
->pass_arg
);
5630 resolve_actual_arglist (args
, target
->attr
.proc
,
5631 is_external_proc (target
) && !target
->formal
);
5633 /* Check if this arglist matches the formal. */
5634 matches
= gfc_arglist_matches_symbol (&args
, target
);
5636 /* Clean up and break out of the loop if we've found it. */
5637 gfc_free_actual_arglist (args
);
5640 e
->value
.compcall
.tbp
= g
->specific
;
5641 genname
= g
->specific_st
->name
;
5642 /* Pass along the name for CLASS methods, where the vtab
5643 procedure pointer component has to be referenced. */
5651 /* Nothing matching found! */
5652 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5653 " '%s' at %L", genname
, &e
->where
);
5657 /* Make sure that we have the right specific instance for the name. */
5658 derived
= get_declared_from_expr (NULL
, NULL
, e
);
5660 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, false, &e
->where
);
5662 e
->value
.compcall
.tbp
= st
->n
.tb
;
5668 /* Resolve a call to a type-bound subroutine. */
5671 resolve_typebound_call (gfc_code
* c
, const char **name
)
5673 gfc_actual_arglist
* newactual
;
5674 gfc_symtree
* target
;
5676 /* Check that's really a SUBROUTINE. */
5677 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5679 gfc_error ("'%s' at %L should be a SUBROUTINE",
5680 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5684 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5687 /* Pass along the name for CLASS methods, where the vtab
5688 procedure pointer component has to be referenced. */
5690 *name
= c
->expr1
->value
.compcall
.name
;
5692 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5695 /* Transform into an ordinary EXEC_CALL for now. */
5697 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5700 c
->ext
.actual
= newactual
;
5701 c
->symtree
= target
;
5702 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5704 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5706 gfc_free_expr (c
->expr1
);
5707 c
->expr1
= gfc_get_expr ();
5708 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5709 c
->expr1
->symtree
= target
;
5710 c
->expr1
->where
= c
->loc
;
5712 return resolve_call (c
);
5716 /* Resolve a component-call expression. */
5718 resolve_compcall (gfc_expr
* e
, const char **name
)
5720 gfc_actual_arglist
* newactual
;
5721 gfc_symtree
* target
;
5723 /* Check that's really a FUNCTION. */
5724 if (!e
->value
.compcall
.tbp
->function
)
5726 gfc_error ("'%s' at %L should be a FUNCTION",
5727 e
->value
.compcall
.name
, &e
->where
);
5731 /* These must not be assign-calls! */
5732 gcc_assert (!e
->value
.compcall
.assign
);
5734 if (check_typebound_baseobject (e
) == FAILURE
)
5737 /* Pass along the name for CLASS methods, where the vtab
5738 procedure pointer component has to be referenced. */
5740 *name
= e
->value
.compcall
.name
;
5742 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5744 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5746 /* Take the rank from the function's symbol. */
5747 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5748 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5750 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5751 arglist to the TBP's binding target. */
5753 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5756 e
->value
.function
.actual
= newactual
;
5757 e
->value
.function
.name
= NULL
;
5758 e
->value
.function
.esym
= target
->n
.sym
;
5759 e
->value
.function
.isym
= NULL
;
5760 e
->symtree
= target
;
5761 e
->ts
= target
->n
.sym
->ts
;
5762 e
->expr_type
= EXPR_FUNCTION
;
5764 /* Resolution is not necessary if this is a class subroutine; this
5765 function only has to identify the specific proc. Resolution of
5766 the call will be done next in resolve_typebound_call. */
5767 return gfc_resolve_expr (e
);
5772 /* Resolve a typebound function, or 'method'. First separate all
5773 the non-CLASS references by calling resolve_compcall directly. */
5776 resolve_typebound_function (gfc_expr
* e
)
5778 gfc_symbol
*declared
;
5789 /* Deal with typebound operators for CLASS objects. */
5790 expr
= e
->value
.compcall
.base_object
;
5791 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5793 /* Since the typebound operators are generic, we have to ensure
5794 that any delays in resolution are corrected and that the vtab
5797 declared
= ts
.u
.derived
;
5798 c
= gfc_find_component (declared
, "_vptr", true, true);
5799 if (c
->ts
.u
.derived
== NULL
)
5800 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5802 if (resolve_compcall (e
, &name
) == FAILURE
)
5805 /* Use the generic name if it is there. */
5806 name
= name
? name
: e
->value
.function
.esym
->name
;
5807 e
->symtree
= expr
->symtree
;
5808 e
->ref
= gfc_copy_ref (expr
->ref
);
5809 gfc_add_vptr_component (e
);
5810 gfc_add_component_ref (e
, name
);
5811 e
->value
.function
.esym
= NULL
;
5816 return resolve_compcall (e
, NULL
);
5818 if (resolve_ref (e
) == FAILURE
)
5821 /* Get the CLASS declared type. */
5822 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
);
5824 /* Weed out cases of the ultimate component being a derived type. */
5825 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5826 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5828 gfc_free_ref_list (new_ref
);
5829 return resolve_compcall (e
, NULL
);
5832 c
= gfc_find_component (declared
, "_data", true, true);
5833 declared
= c
->ts
.u
.derived
;
5835 /* Treat the call as if it is a typebound procedure, in order to roll
5836 out the correct name for the specific function. */
5837 if (resolve_compcall (e
, &name
) == FAILURE
)
5841 /* Then convert the expression to a procedure pointer component call. */
5842 e
->value
.function
.esym
= NULL
;
5848 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5849 gfc_add_vptr_component (e
);
5850 gfc_add_component_ref (e
, name
);
5852 /* Recover the typespec for the expression. This is really only
5853 necessary for generic procedures, where the additional call
5854 to gfc_add_component_ref seems to throw the collection of the
5855 correct typespec. */
5860 /* Resolve a typebound subroutine, or 'method'. First separate all
5861 the non-CLASS references by calling resolve_typebound_call
5865 resolve_typebound_subroutine (gfc_code
*code
)
5867 gfc_symbol
*declared
;
5876 st
= code
->expr1
->symtree
;
5878 /* Deal with typebound operators for CLASS objects. */
5879 expr
= code
->expr1
->value
.compcall
.base_object
;
5880 if (expr
&& expr
->symtree
->n
.sym
->ts
.type
== BT_CLASS
5881 && code
->expr1
->value
.compcall
.name
)
5883 /* Since the typebound operators are generic, we have to ensure
5884 that any delays in resolution are corrected and that the vtab
5886 ts
= expr
->symtree
->n
.sym
->ts
;
5887 declared
= ts
.u
.derived
;
5888 c
= gfc_find_component (declared
, "_vptr", true, true);
5889 if (c
->ts
.u
.derived
== NULL
)
5890 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5892 if (resolve_typebound_call (code
, &name
) == FAILURE
)
5895 /* Use the generic name if it is there. */
5896 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5897 code
->expr1
->symtree
= expr
->symtree
;
5898 expr
->symtree
->n
.sym
->ts
.u
.derived
= declared
;
5899 gfc_add_vptr_component (code
->expr1
);
5900 gfc_add_component_ref (code
->expr1
, name
);
5901 code
->expr1
->value
.function
.esym
= NULL
;
5906 return resolve_typebound_call (code
, NULL
);
5908 if (resolve_ref (code
->expr1
) == FAILURE
)
5911 /* Get the CLASS declared type. */
5912 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
);
5914 /* Weed out cases of the ultimate component being a derived type. */
5915 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5916 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5918 gfc_free_ref_list (new_ref
);
5919 return resolve_typebound_call (code
, NULL
);
5922 if (resolve_typebound_call (code
, &name
) == FAILURE
)
5924 ts
= code
->expr1
->ts
;
5926 /* Then convert the expression to a procedure pointer component call. */
5927 code
->expr1
->value
.function
.esym
= NULL
;
5928 code
->expr1
->symtree
= st
;
5931 code
->expr1
->ref
= new_ref
;
5933 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5934 gfc_add_vptr_component (code
->expr1
);
5935 gfc_add_component_ref (code
->expr1
, name
);
5937 /* Recover the typespec for the expression. This is really only
5938 necessary for generic procedures, where the additional call
5939 to gfc_add_component_ref seems to throw the collection of the
5940 correct typespec. */
5941 code
->expr1
->ts
= ts
;
5946 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5949 resolve_ppc_call (gfc_code
* c
)
5951 gfc_component
*comp
;
5954 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
5957 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5958 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5960 if (!comp
->attr
.subroutine
)
5961 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5963 if (resolve_ref (c
->expr1
) == FAILURE
)
5966 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
5969 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5971 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5972 comp
->formal
== NULL
) == FAILURE
)
5975 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5981 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5984 resolve_expr_ppc (gfc_expr
* e
)
5986 gfc_component
*comp
;
5989 b
= gfc_is_proc_ptr_comp (e
, &comp
);
5992 /* Convert to EXPR_FUNCTION. */
5993 e
->expr_type
= EXPR_FUNCTION
;
5994 e
->value
.function
.isym
= NULL
;
5995 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
5997 if (comp
->as
!= NULL
)
5998 e
->rank
= comp
->as
->rank
;
6000 if (!comp
->attr
.function
)
6001 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6003 if (resolve_ref (e
) == FAILURE
)
6006 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6007 comp
->formal
== NULL
) == FAILURE
)
6010 if (update_ppc_arglist (e
) == FAILURE
)
6013 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6020 gfc_is_expandable_expr (gfc_expr
*e
)
6022 gfc_constructor
*con
;
6024 if (e
->expr_type
== EXPR_ARRAY
)
6026 /* Traverse the constructor looking for variables that are flavor
6027 parameter. Parameters must be expanded since they are fully used at
6029 con
= gfc_constructor_first (e
->value
.constructor
);
6030 for (; con
; con
= gfc_constructor_next (con
))
6032 if (con
->expr
->expr_type
== EXPR_VARIABLE
6033 && con
->expr
->symtree
6034 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6035 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6037 if (con
->expr
->expr_type
== EXPR_ARRAY
6038 && gfc_is_expandable_expr (con
->expr
))
6046 /* Resolve an expression. That is, make sure that types of operands agree
6047 with their operators, intrinsic operators are converted to function calls
6048 for overloaded types and unresolved function references are resolved. */
6051 gfc_resolve_expr (gfc_expr
*e
)
6059 /* inquiry_argument only applies to variables. */
6060 inquiry_save
= inquiry_argument
;
6061 if (e
->expr_type
!= EXPR_VARIABLE
)
6062 inquiry_argument
= false;
6064 switch (e
->expr_type
)
6067 t
= resolve_operator (e
);
6073 if (check_host_association (e
))
6074 t
= resolve_function (e
);
6077 t
= resolve_variable (e
);
6079 expression_rank (e
);
6082 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6083 && e
->ref
->type
!= REF_SUBSTRING
)
6084 gfc_resolve_substring_charlen (e
);
6089 t
= resolve_typebound_function (e
);
6092 case EXPR_SUBSTRING
:
6093 t
= resolve_ref (e
);
6102 t
= resolve_expr_ppc (e
);
6107 if (resolve_ref (e
) == FAILURE
)
6110 t
= gfc_resolve_array_constructor (e
);
6111 /* Also try to expand a constructor. */
6114 expression_rank (e
);
6115 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6116 gfc_expand_constructor (e
, false);
6119 /* This provides the opportunity for the length of constructors with
6120 character valued function elements to propagate the string length
6121 to the expression. */
6122 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6124 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6125 here rather then add a duplicate test for it above. */
6126 gfc_expand_constructor (e
, false);
6127 t
= gfc_resolve_character_array_constructor (e
);
6132 case EXPR_STRUCTURE
:
6133 t
= resolve_ref (e
);
6137 t
= resolve_structure_cons (e
, 0);
6141 t
= gfc_simplify_expr (e
, 0);
6145 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6148 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6151 inquiry_argument
= inquiry_save
;
6157 /* Resolve an expression from an iterator. They must be scalar and have
6158 INTEGER or (optionally) REAL type. */
6161 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6162 const char *name_msgid
)
6164 if (gfc_resolve_expr (expr
) == FAILURE
)
6167 if (expr
->rank
!= 0)
6169 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6173 if (expr
->ts
.type
!= BT_INTEGER
)
6175 if (expr
->ts
.type
== BT_REAL
)
6178 return gfc_notify_std (GFC_STD_F95_DEL
,
6179 "Deleted feature: %s at %L must be integer",
6180 _(name_msgid
), &expr
->where
);
6183 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6190 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6198 /* Resolve the expressions in an iterator structure. If REAL_OK is
6199 false allow only INTEGER type iterators, otherwise allow REAL types. */
6202 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6204 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6208 if (gfc_check_vardef_context (iter
->var
, false, _("iterator variable"))
6212 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6213 "Start expression in DO loop") == FAILURE
)
6216 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6217 "End expression in DO loop") == FAILURE
)
6220 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6221 "Step expression in DO loop") == FAILURE
)
6224 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6226 if ((iter
->step
->ts
.type
== BT_INTEGER
6227 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6228 || (iter
->step
->ts
.type
== BT_REAL
6229 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6231 gfc_error ("Step expression in DO loop at %L cannot be zero",
6232 &iter
->step
->where
);
6237 /* Convert start, end, and step to the same type as var. */
6238 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6239 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6240 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6242 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6243 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6244 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6246 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6247 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6248 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6250 if (iter
->start
->expr_type
== EXPR_CONSTANT
6251 && iter
->end
->expr_type
== EXPR_CONSTANT
6252 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6255 if (iter
->start
->ts
.type
== BT_INTEGER
)
6257 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6258 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6262 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6263 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6265 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6266 gfc_warning ("DO loop at %L will be executed zero times",
6267 &iter
->step
->where
);
6274 /* Traversal function for find_forall_index. f == 2 signals that
6275 that variable itself is not to be checked - only the references. */
6278 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6280 if (expr
->expr_type
!= EXPR_VARIABLE
)
6283 /* A scalar assignment */
6284 if (!expr
->ref
|| *f
== 1)
6286 if (expr
->symtree
->n
.sym
== sym
)
6298 /* Check whether the FORALL index appears in the expression or not.
6299 Returns SUCCESS if SYM is found in EXPR. */
6302 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6304 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6311 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6312 to be a scalar INTEGER variable. The subscripts and stride are scalar
6313 INTEGERs, and if stride is a constant it must be nonzero.
6314 Furthermore "A subscript or stride in a forall-triplet-spec shall
6315 not contain a reference to any index-name in the
6316 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6319 resolve_forall_iterators (gfc_forall_iterator
*it
)
6321 gfc_forall_iterator
*iter
, *iter2
;
6323 for (iter
= it
; iter
; iter
= iter
->next
)
6325 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6326 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6327 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6330 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6331 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6332 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6333 &iter
->start
->where
);
6334 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6335 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6337 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6338 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6339 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6341 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6342 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6344 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6346 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6347 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6348 &iter
->stride
->where
, "INTEGER");
6350 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6351 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6352 gfc_error ("FORALL stride expression at %L cannot be zero",
6353 &iter
->stride
->where
);
6355 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6356 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
6359 for (iter
= it
; iter
; iter
= iter
->next
)
6360 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6362 if (find_forall_index (iter2
->start
,
6363 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6364 || find_forall_index (iter2
->end
,
6365 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6366 || find_forall_index (iter2
->stride
,
6367 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6368 gfc_error ("FORALL index '%s' may not appear in triplet "
6369 "specification at %L", iter
->var
->symtree
->name
,
6370 &iter2
->start
->where
);
6375 /* Given a pointer to a symbol that is a derived type, see if it's
6376 inaccessible, i.e. if it's defined in another module and the components are
6377 PRIVATE. The search is recursive if necessary. Returns zero if no
6378 inaccessible components are found, nonzero otherwise. */
6381 derived_inaccessible (gfc_symbol
*sym
)
6385 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6388 for (c
= sym
->components
; c
; c
= c
->next
)
6390 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6398 /* Resolve the argument of a deallocate expression. The expression must be
6399 a pointer or a full array. */
6402 resolve_deallocate_expr (gfc_expr
*e
)
6404 symbol_attribute attr
;
6405 int allocatable
, pointer
;
6410 if (gfc_resolve_expr (e
) == FAILURE
)
6413 if (e
->expr_type
!= EXPR_VARIABLE
)
6416 sym
= e
->symtree
->n
.sym
;
6418 if (sym
->ts
.type
== BT_CLASS
)
6420 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6421 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6425 allocatable
= sym
->attr
.allocatable
;
6426 pointer
= sym
->attr
.pointer
;
6428 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6433 if (ref
->u
.ar
.type
!= AR_FULL
)
6438 c
= ref
->u
.c
.component
;
6439 if (c
->ts
.type
== BT_CLASS
)
6441 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6442 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6446 allocatable
= c
->attr
.allocatable
;
6447 pointer
= c
->attr
.pointer
;
6457 attr
= gfc_expr_attr (e
);
6459 if (allocatable
== 0 && attr
.pointer
== 0)
6462 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6468 && gfc_check_vardef_context (e
, true, _("DEALLOCATE object")) == FAILURE
)
6470 if (gfc_check_vardef_context (e
, false, _("DEALLOCATE object")) == FAILURE
)
6477 /* Returns true if the expression e contains a reference to the symbol sym. */
6479 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6481 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6488 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6490 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6494 /* Given the expression node e for an allocatable/pointer of derived type to be
6495 allocated, get the expression node to be initialized afterwards (needed for
6496 derived types with default initializers, and derived types with allocatable
6497 components that need nullification.) */
6500 gfc_expr_to_initialize (gfc_expr
*e
)
6506 result
= gfc_copy_expr (e
);
6508 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6509 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6510 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6512 ref
->u
.ar
.type
= AR_FULL
;
6514 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6515 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6517 result
->rank
= ref
->u
.ar
.dimen
;
6525 /* If the last ref of an expression is an array ref, return a copy of the
6526 expression with that one removed. Otherwise, a copy of the original
6527 expression. This is used for allocate-expressions and pointer assignment
6528 LHS, where there may be an array specification that needs to be stripped
6529 off when using gfc_check_vardef_context. */
6532 remove_last_array_ref (gfc_expr
* e
)
6537 e2
= gfc_copy_expr (e
);
6538 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6539 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6541 gfc_free_ref_list (*r
);
6550 /* Used in resolve_allocate_expr to check that a allocation-object and
6551 a source-expr are conformable. This does not catch all possible
6552 cases; in particular a runtime checking is needed. */
6555 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6558 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6560 /* First compare rank. */
6561 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6563 gfc_error ("Source-expr at %L must be scalar or have the "
6564 "same rank as the allocate-object at %L",
6565 &e1
->where
, &e2
->where
);
6576 for (i
= 0; i
< e1
->rank
; i
++)
6578 if (tail
->u
.ar
.end
[i
])
6580 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6581 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6582 mpz_add_ui (s
, s
, 1);
6586 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6589 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6591 gfc_error ("Source-expr at %L and allocate-object at %L must "
6592 "have the same shape", &e1
->where
, &e2
->where
);
6605 /* Resolve the expression in an ALLOCATE statement, doing the additional
6606 checks to see whether the expression is OK or not. The expression must
6607 have a trailing array reference that gives the size of the array. */
6610 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6612 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6614 symbol_attribute attr
;
6615 gfc_ref
*ref
, *ref2
;
6618 gfc_symbol
*sym
= NULL
;
6623 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6624 checking of coarrays. */
6625 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6626 if (ref
->next
== NULL
)
6629 if (ref
&& ref
->type
== REF_ARRAY
)
6630 ref
->u
.ar
.in_allocate
= true;
6632 if (gfc_resolve_expr (e
) == FAILURE
)
6635 /* Make sure the expression is allocatable or a pointer. If it is
6636 pointer, the next-to-last reference must be a pointer. */
6640 sym
= e
->symtree
->n
.sym
;
6642 /* Check whether ultimate component is abstract and CLASS. */
6645 if (e
->expr_type
!= EXPR_VARIABLE
)
6648 attr
= gfc_expr_attr (e
);
6649 pointer
= attr
.pointer
;
6650 dimension
= attr
.dimension
;
6651 codimension
= attr
.codimension
;
6655 if (sym
->ts
.type
== BT_CLASS
)
6657 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6658 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6659 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6660 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6661 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6665 allocatable
= sym
->attr
.allocatable
;
6666 pointer
= sym
->attr
.pointer
;
6667 dimension
= sym
->attr
.dimension
;
6668 codimension
= sym
->attr
.codimension
;
6671 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6676 if (ref
->next
!= NULL
)
6682 if (gfc_is_coindexed (e
))
6684 gfc_error ("Coindexed allocatable object at %L",
6689 c
= ref
->u
.c
.component
;
6690 if (c
->ts
.type
== BT_CLASS
)
6692 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6693 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6694 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6695 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6696 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6700 allocatable
= c
->attr
.allocatable
;
6701 pointer
= c
->attr
.pointer
;
6702 dimension
= c
->attr
.dimension
;
6703 codimension
= c
->attr
.codimension
;
6704 is_abstract
= c
->attr
.abstract
;
6716 if (allocatable
== 0 && pointer
== 0)
6718 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6723 /* Some checks for the SOURCE tag. */
6726 /* Check F03:C631. */
6727 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6729 gfc_error ("Type of entity at %L is type incompatible with "
6730 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6734 /* Check F03:C632 and restriction following Note 6.18. */
6735 if (code
->expr3
->rank
> 0
6736 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
6739 /* Check F03:C633. */
6740 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
6742 gfc_error ("The allocate-object at %L and the source-expr at %L "
6743 "shall have the same kind type parameter",
6744 &e
->where
, &code
->expr3
->where
);
6749 /* Check F08:C629. */
6750 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6753 gcc_assert (e
->ts
.type
== BT_CLASS
);
6754 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6755 "type-spec or source-expr", sym
->name
, &e
->where
);
6759 /* In the variable definition context checks, gfc_expr_attr is used
6760 on the expression. This is fooled by the array specification
6761 present in e, thus we have to eliminate that one temporarily. */
6762 e2
= remove_last_array_ref (e
);
6764 if (t
== SUCCESS
&& pointer
)
6765 t
= gfc_check_vardef_context (e2
, true, _("ALLOCATE object"));
6767 t
= gfc_check_vardef_context (e2
, false, _("ALLOCATE object"));
6774 /* Set up default initializer if needed. */
6778 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6779 ts
= code
->ext
.alloc
.ts
;
6783 if (ts
.type
== BT_CLASS
)
6784 ts
= ts
.u
.derived
->components
->ts
;
6786 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6788 gfc_code
*init_st
= gfc_get_code ();
6789 init_st
->loc
= code
->loc
;
6790 init_st
->op
= EXEC_INIT_ASSIGN
;
6791 init_st
->expr1
= gfc_expr_to_initialize (e
);
6792 init_st
->expr2
= init_e
;
6793 init_st
->next
= code
->next
;
6794 code
->next
= init_st
;
6797 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6799 /* Default initialization via MOLD (non-polymorphic). */
6800 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6801 gfc_resolve_expr (rhs
);
6802 gfc_free_expr (code
->expr3
);
6806 if (e
->ts
.type
== BT_CLASS
)
6808 /* Make sure the vtab symbol is present when
6809 the module variables are generated. */
6810 gfc_typespec ts
= e
->ts
;
6812 ts
= code
->expr3
->ts
;
6813 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6814 ts
= code
->ext
.alloc
.ts
;
6815 gfc_find_derived_vtab (ts
.u
.derived
);
6818 if (pointer
|| (dimension
== 0 && codimension
== 0))
6821 /* Make sure the last reference node is an array specifiction. */
6823 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6824 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6826 gfc_error ("Array specification required in ALLOCATE statement "
6827 "at %L", &e
->where
);
6831 /* Make sure that the array section reference makes sense in the
6832 context of an ALLOCATE specification. */
6836 if (codimension
&& ar
->codimen
== 0)
6838 gfc_error ("Coarray specification required in ALLOCATE statement "
6839 "at %L", &e
->where
);
6843 for (i
= 0; i
< ar
->dimen
; i
++)
6845 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6848 switch (ar
->dimen_type
[i
])
6854 if (ar
->start
[i
] != NULL
6855 && ar
->end
[i
] != NULL
6856 && ar
->stride
[i
] == NULL
)
6859 /* Fall Through... */
6864 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6870 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6872 sym
= a
->expr
->symtree
->n
.sym
;
6874 /* TODO - check derived type components. */
6875 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
6878 if ((ar
->start
[i
] != NULL
6879 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
6880 || (ar
->end
[i
] != NULL
6881 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
6883 gfc_error ("'%s' must not appear in the array specification at "
6884 "%L in the same ALLOCATE statement where it is "
6885 "itself allocated", sym
->name
, &ar
->where
);
6891 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
6893 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
6894 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
6896 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
6898 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6899 "statement at %L", &e
->where
);
6905 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
6906 && ar
->stride
[i
] == NULL
)
6909 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6914 if (codimension
&& ar
->as
->rank
== 0)
6916 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6917 "at %L", &e
->where
);
6929 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
6931 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
6932 gfc_alloc
*a
, *p
, *q
;
6935 errmsg
= code
->expr2
;
6937 /* Check the stat variable. */
6940 gfc_check_vardef_context (stat
, false, _("STAT variable"));
6942 if ((stat
->ts
.type
!= BT_INTEGER
6943 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
6944 || stat
->ref
->type
== REF_COMPONENT
)))
6946 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6947 "variable", &stat
->where
);
6949 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
6950 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
6952 gfc_ref
*ref1
, *ref2
;
6955 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
6956 ref1
= ref1
->next
, ref2
= ref2
->next
)
6958 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
6960 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
6969 gfc_error ("Stat-variable at %L shall not be %sd within "
6970 "the same %s statement", &stat
->where
, fcn
, fcn
);
6976 /* Check the errmsg variable. */
6980 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6983 gfc_check_vardef_context (errmsg
, false, _("ERRMSG variable"));
6985 if ((errmsg
->ts
.type
!= BT_CHARACTER
6987 && (errmsg
->ref
->type
== REF_ARRAY
6988 || errmsg
->ref
->type
== REF_COMPONENT
)))
6989 || errmsg
->rank
> 0 )
6990 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
6991 "variable", &errmsg
->where
);
6993 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
6994 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
6996 gfc_ref
*ref1
, *ref2
;
6999 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7000 ref1
= ref1
->next
, ref2
= ref2
->next
)
7002 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7004 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7013 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7014 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7020 /* Check that an allocate-object appears only once in the statement.
7021 FIXME: Checking derived types is disabled. */
7022 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7025 for (q
= p
->next
; q
; q
= q
->next
)
7028 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7030 /* This is a potential collision. */
7031 gfc_ref
*pr
= pe
->ref
;
7032 gfc_ref
*qr
= qe
->ref
;
7034 /* Follow the references until
7035 a) They start to differ, in which case there is no error;
7036 you can deallocate a%b and a%c in a single statement
7037 b) Both of them stop, which is an error
7038 c) One of them stops, which is also an error. */
7041 if (pr
== NULL
&& qr
== NULL
)
7043 gfc_error ("Allocate-object at %L also appears at %L",
7044 &pe
->where
, &qe
->where
);
7047 else if (pr
!= NULL
&& qr
== NULL
)
7049 gfc_error ("Allocate-object at %L is subobject of"
7050 " object at %L", &pe
->where
, &qe
->where
);
7053 else if (pr
== NULL
&& qr
!= NULL
)
7055 gfc_error ("Allocate-object at %L is subobject of"
7056 " object at %L", &qe
->where
, &pe
->where
);
7059 /* Here, pr != NULL && qr != NULL */
7060 gcc_assert(pr
->type
== qr
->type
);
7061 if (pr
->type
== REF_ARRAY
)
7063 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7065 gcc_assert (qr
->type
== REF_ARRAY
);
7067 if (pr
->next
&& qr
->next
)
7069 gfc_array_ref
*par
= &(pr
->u
.ar
);
7070 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7071 if (gfc_dep_compare_expr (par
->start
[0],
7072 qar
->start
[0]) != 0)
7078 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7089 if (strcmp (fcn
, "ALLOCATE") == 0)
7091 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7092 resolve_allocate_expr (a
->expr
, code
);
7096 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7097 resolve_deallocate_expr (a
->expr
);
7102 /************ SELECT CASE resolution subroutines ************/
7104 /* Callback function for our mergesort variant. Determines interval
7105 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7106 op1 > op2. Assumes we're not dealing with the default case.
7107 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7108 There are nine situations to check. */
7111 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7115 if (op1
->low
== NULL
) /* op1 = (:L) */
7117 /* op2 = (:N), so overlap. */
7119 /* op2 = (M:) or (M:N), L < M */
7120 if (op2
->low
!= NULL
7121 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7124 else if (op1
->high
== NULL
) /* op1 = (K:) */
7126 /* op2 = (M:), so overlap. */
7128 /* op2 = (:N) or (M:N), K > N */
7129 if (op2
->high
!= NULL
7130 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7133 else /* op1 = (K:L) */
7135 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7136 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7138 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7139 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7141 else /* op2 = (M:N) */
7145 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7148 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7157 /* Merge-sort a double linked case list, detecting overlap in the
7158 process. LIST is the head of the double linked case list before it
7159 is sorted. Returns the head of the sorted list if we don't see any
7160 overlap, or NULL otherwise. */
7163 check_case_overlap (gfc_case
*list
)
7165 gfc_case
*p
, *q
, *e
, *tail
;
7166 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7168 /* If the passed list was empty, return immediately. */
7175 /* Loop unconditionally. The only exit from this loop is a return
7176 statement, when we've finished sorting the case list. */
7183 /* Count the number of merges we do in this pass. */
7186 /* Loop while there exists a merge to be done. */
7191 /* Count this merge. */
7194 /* Cut the list in two pieces by stepping INSIZE places
7195 forward in the list, starting from P. */
7198 for (i
= 0; i
< insize
; i
++)
7207 /* Now we have two lists. Merge them! */
7208 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7210 /* See from which the next case to merge comes from. */
7213 /* P is empty so the next case must come from Q. */
7218 else if (qsize
== 0 || q
== NULL
)
7227 cmp
= compare_cases (p
, q
);
7230 /* The whole case range for P is less than the
7238 /* The whole case range for Q is greater than
7239 the case range for P. */
7246 /* The cases overlap, or they are the same
7247 element in the list. Either way, we must
7248 issue an error and get the next case from P. */
7249 /* FIXME: Sort P and Q by line number. */
7250 gfc_error ("CASE label at %L overlaps with CASE "
7251 "label at %L", &p
->where
, &q
->where
);
7259 /* Add the next element to the merged list. */
7268 /* P has now stepped INSIZE places along, and so has Q. So
7269 they're the same. */
7274 /* If we have done only one merge or none at all, we've
7275 finished sorting the cases. */
7284 /* Otherwise repeat, merging lists twice the size. */
7290 /* Check to see if an expression is suitable for use in a CASE statement.
7291 Makes sure that all case expressions are scalar constants of the same
7292 type. Return FAILURE if anything is wrong. */
7295 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7297 if (e
== NULL
) return SUCCESS
;
7299 if (e
->ts
.type
!= case_expr
->ts
.type
)
7301 gfc_error ("Expression in CASE statement at %L must be of type %s",
7302 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7306 /* C805 (R808) For a given case-construct, each case-value shall be of
7307 the same type as case-expr. For character type, length differences
7308 are allowed, but the kind type parameters shall be the same. */
7310 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7312 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7313 &e
->where
, case_expr
->ts
.kind
);
7317 /* Convert the case value kind to that of case expression kind,
7320 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7321 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7325 gfc_error ("Expression in CASE statement at %L must be scalar",
7334 /* Given a completely parsed select statement, we:
7336 - Validate all expressions and code within the SELECT.
7337 - Make sure that the selection expression is not of the wrong type.
7338 - Make sure that no case ranges overlap.
7339 - Eliminate unreachable cases and unreachable code resulting from
7340 removing case labels.
7342 The standard does allow unreachable cases, e.g. CASE (5:3). But
7343 they are a hassle for code generation, and to prevent that, we just
7344 cut them out here. This is not necessary for overlapping cases
7345 because they are illegal and we never even try to generate code.
7347 We have the additional caveat that a SELECT construct could have
7348 been a computed GOTO in the source code. Fortunately we can fairly
7349 easily work around that here: The case_expr for a "real" SELECT CASE
7350 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7351 we have to do is make sure that the case_expr is a scalar integer
7355 resolve_select (gfc_code
*code
)
7358 gfc_expr
*case_expr
;
7359 gfc_case
*cp
, *default_case
, *tail
, *head
;
7360 int seen_unreachable
;
7366 if (code
->expr1
== NULL
)
7368 /* This was actually a computed GOTO statement. */
7369 case_expr
= code
->expr2
;
7370 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7371 gfc_error ("Selection expression in computed GOTO statement "
7372 "at %L must be a scalar integer expression",
7375 /* Further checking is not necessary because this SELECT was built
7376 by the compiler, so it should always be OK. Just move the
7377 case_expr from expr2 to expr so that we can handle computed
7378 GOTOs as normal SELECTs from here on. */
7379 code
->expr1
= code
->expr2
;
7384 case_expr
= code
->expr1
;
7386 type
= case_expr
->ts
.type
;
7387 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7389 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7390 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7392 /* Punt. Going on here just produce more garbage error messages. */
7396 if (case_expr
->rank
!= 0)
7398 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7399 "expression", &case_expr
->where
);
7406 /* Raise a warning if an INTEGER case value exceeds the range of
7407 the case-expr. Later, all expressions will be promoted to the
7408 largest kind of all case-labels. */
7410 if (type
== BT_INTEGER
)
7411 for (body
= code
->block
; body
; body
= body
->block
)
7412 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7415 && gfc_check_integer_range (cp
->low
->value
.integer
,
7416 case_expr
->ts
.kind
) != ARITH_OK
)
7417 gfc_warning ("Expression in CASE statement at %L is "
7418 "not in the range of %s", &cp
->low
->where
,
7419 gfc_typename (&case_expr
->ts
));
7422 && cp
->low
!= cp
->high
7423 && gfc_check_integer_range (cp
->high
->value
.integer
,
7424 case_expr
->ts
.kind
) != ARITH_OK
)
7425 gfc_warning ("Expression in CASE statement at %L is "
7426 "not in the range of %s", &cp
->high
->where
,
7427 gfc_typename (&case_expr
->ts
));
7430 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7431 of the SELECT CASE expression and its CASE values. Walk the lists
7432 of case values, and if we find a mismatch, promote case_expr to
7433 the appropriate kind. */
7435 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7437 for (body
= code
->block
; body
; body
= body
->block
)
7439 /* Walk the case label list. */
7440 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7442 /* Intercept the DEFAULT case. It does not have a kind. */
7443 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7446 /* Unreachable case ranges are discarded, so ignore. */
7447 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7448 && cp
->low
!= cp
->high
7449 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7453 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7454 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7456 if (cp
->high
!= NULL
7457 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7458 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7463 /* Assume there is no DEFAULT case. */
7464 default_case
= NULL
;
7469 for (body
= code
->block
; body
; body
= body
->block
)
7471 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7473 seen_unreachable
= 0;
7475 /* Walk the case label list, making sure that all case labels
7477 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7479 /* Count the number of cases in the whole construct. */
7482 /* Intercept the DEFAULT case. */
7483 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7485 if (default_case
!= NULL
)
7487 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7488 "by a second DEFAULT CASE at %L",
7489 &default_case
->where
, &cp
->where
);
7500 /* Deal with single value cases and case ranges. Errors are
7501 issued from the validation function. */
7502 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7503 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7509 if (type
== BT_LOGICAL
7510 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7511 || cp
->low
!= cp
->high
))
7513 gfc_error ("Logical range in CASE statement at %L is not "
7514 "allowed", &cp
->low
->where
);
7519 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7522 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7523 if (value
& seen_logical
)
7525 gfc_error ("Constant logical value in CASE statement "
7526 "is repeated at %L",
7531 seen_logical
|= value
;
7534 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7535 && cp
->low
!= cp
->high
7536 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7538 if (gfc_option
.warn_surprising
)
7539 gfc_warning ("Range specification at %L can never "
7540 "be matched", &cp
->where
);
7542 cp
->unreachable
= 1;
7543 seen_unreachable
= 1;
7547 /* If the case range can be matched, it can also overlap with
7548 other cases. To make sure it does not, we put it in a
7549 double linked list here. We sort that with a merge sort
7550 later on to detect any overlapping cases. */
7554 head
->right
= head
->left
= NULL
;
7559 tail
->right
->left
= tail
;
7566 /* It there was a failure in the previous case label, give up
7567 for this case label list. Continue with the next block. */
7571 /* See if any case labels that are unreachable have been seen.
7572 If so, we eliminate them. This is a bit of a kludge because
7573 the case lists for a single case statement (label) is a
7574 single forward linked lists. */
7575 if (seen_unreachable
)
7577 /* Advance until the first case in the list is reachable. */
7578 while (body
->ext
.block
.case_list
!= NULL
7579 && body
->ext
.block
.case_list
->unreachable
)
7581 gfc_case
*n
= body
->ext
.block
.case_list
;
7582 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7584 gfc_free_case_list (n
);
7587 /* Strip all other unreachable cases. */
7588 if (body
->ext
.block
.case_list
)
7590 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7592 if (cp
->next
->unreachable
)
7594 gfc_case
*n
= cp
->next
;
7595 cp
->next
= cp
->next
->next
;
7597 gfc_free_case_list (n
);
7604 /* See if there were overlapping cases. If the check returns NULL,
7605 there was overlap. In that case we don't do anything. If head
7606 is non-NULL, we prepend the DEFAULT case. The sorted list can
7607 then used during code generation for SELECT CASE constructs with
7608 a case expression of a CHARACTER type. */
7611 head
= check_case_overlap (head
);
7613 /* Prepend the default_case if it is there. */
7614 if (head
!= NULL
&& default_case
)
7616 default_case
->left
= NULL
;
7617 default_case
->right
= head
;
7618 head
->left
= default_case
;
7622 /* Eliminate dead blocks that may be the result if we've seen
7623 unreachable case labels for a block. */
7624 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7626 if (body
->block
->ext
.block
.case_list
== NULL
)
7628 /* Cut the unreachable block from the code chain. */
7629 gfc_code
*c
= body
->block
;
7630 body
->block
= c
->block
;
7632 /* Kill the dead block, but not the blocks below it. */
7634 gfc_free_statements (c
);
7638 /* More than two cases is legal but insane for logical selects.
7639 Issue a warning for it. */
7640 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7642 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7647 /* Check if a derived type is extensible. */
7650 gfc_type_is_extensible (gfc_symbol
*sym
)
7652 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7656 /* Resolve an associate name: Resolve target and ensure the type-spec is
7657 correct as well as possibly the array-spec. */
7660 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7664 gcc_assert (sym
->assoc
);
7665 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7667 /* If this is for SELECT TYPE, the target may not yet be set. In that
7668 case, return. Resolution will be called later manually again when
7670 target
= sym
->assoc
->target
;
7673 gcc_assert (!sym
->assoc
->dangling
);
7675 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7678 /* For variable targets, we get some attributes from the target. */
7679 if (target
->expr_type
== EXPR_VARIABLE
)
7683 gcc_assert (target
->symtree
);
7684 tsym
= target
->symtree
->n
.sym
;
7686 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7687 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7689 sym
->attr
.target
= (tsym
->attr
.target
|| tsym
->attr
.pointer
);
7692 /* Get type if this was not already set. Note that it can be
7693 some other type than the target in case this is a SELECT TYPE
7694 selector! So we must not update when the type is already there. */
7695 if (sym
->ts
.type
== BT_UNKNOWN
)
7696 sym
->ts
= target
->ts
;
7697 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7699 /* See if this is a valid association-to-variable. */
7700 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7701 && !gfc_has_vector_subscript (target
));
7703 /* Finally resolve if this is an array or not. */
7704 if (sym
->attr
.dimension
&& target
->rank
== 0)
7706 gfc_error ("Associate-name '%s' at %L is used as array",
7707 sym
->name
, &sym
->declared_at
);
7708 sym
->attr
.dimension
= 0;
7711 if (target
->rank
> 0)
7712 sym
->attr
.dimension
= 1;
7714 if (sym
->attr
.dimension
)
7716 sym
->as
= gfc_get_array_spec ();
7717 sym
->as
->rank
= target
->rank
;
7718 sym
->as
->type
= AS_DEFERRED
;
7720 /* Target must not be coindexed, thus the associate-variable
7722 sym
->as
->corank
= 0;
7727 /* Resolve a SELECT TYPE statement. */
7730 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7732 gfc_symbol
*selector_type
;
7733 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7734 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7737 char name
[GFC_MAX_SYMBOL_LEN
];
7741 ns
= code
->ext
.block
.ns
;
7744 /* Check for F03:C813. */
7745 if (code
->expr1
->ts
.type
!= BT_CLASS
7746 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7748 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7749 "at %L", &code
->loc
);
7755 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7756 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7757 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7760 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7762 /* Loop over TYPE IS / CLASS IS cases. */
7763 for (body
= code
->block
; body
; body
= body
->block
)
7765 c
= body
->ext
.block
.case_list
;
7767 /* Check F03:C815. */
7768 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7769 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7771 gfc_error ("Derived type '%s' at %L must be extensible",
7772 c
->ts
.u
.derived
->name
, &c
->where
);
7777 /* Check F03:C816. */
7778 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7779 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
7781 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7782 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7787 /* Intercept the DEFAULT case. */
7788 if (c
->ts
.type
== BT_UNKNOWN
)
7790 /* Check F03:C818. */
7793 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7794 "by a second DEFAULT CASE at %L",
7795 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7800 default_case
= body
;
7807 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7808 target if present. If there are any EXIT statements referring to the
7809 SELECT TYPE construct, this is no problem because the gfc_code
7810 reference stays the same and EXIT is equally possible from the BLOCK
7811 it is changed to. */
7812 code
->op
= EXEC_BLOCK
;
7815 gfc_association_list
* assoc
;
7817 assoc
= gfc_get_association_list ();
7818 assoc
->st
= code
->expr1
->symtree
;
7819 assoc
->target
= gfc_copy_expr (code
->expr2
);
7820 /* assoc->variable will be set by resolve_assoc_var. */
7822 code
->ext
.block
.assoc
= assoc
;
7823 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
7825 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
7828 code
->ext
.block
.assoc
= NULL
;
7830 /* Add EXEC_SELECT to switch on type. */
7831 new_st
= gfc_get_code ();
7832 new_st
->op
= code
->op
;
7833 new_st
->expr1
= code
->expr1
;
7834 new_st
->expr2
= code
->expr2
;
7835 new_st
->block
= code
->block
;
7836 code
->expr1
= code
->expr2
= NULL
;
7841 ns
->code
->next
= new_st
;
7843 code
->op
= EXEC_SELECT
;
7844 gfc_add_vptr_component (code
->expr1
);
7845 gfc_add_hash_component (code
->expr1
);
7847 /* Loop over TYPE IS / CLASS IS cases. */
7848 for (body
= code
->block
; body
; body
= body
->block
)
7850 c
= body
->ext
.block
.case_list
;
7852 if (c
->ts
.type
== BT_DERIVED
)
7853 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7854 c
->ts
.u
.derived
->hash_value
);
7856 else if (c
->ts
.type
== BT_UNKNOWN
)
7859 /* Associate temporary to selector. This should only be done
7860 when this case is actually true, so build a new ASSOCIATE
7861 that does precisely this here (instead of using the
7864 if (c
->ts
.type
== BT_CLASS
)
7865 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
7867 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
7868 st
= gfc_find_symtree (ns
->sym_root
, name
);
7869 gcc_assert (st
->n
.sym
->assoc
);
7870 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
7871 if (c
->ts
.type
== BT_DERIVED
)
7872 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
7874 new_st
= gfc_get_code ();
7875 new_st
->op
= EXEC_BLOCK
;
7876 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
7877 new_st
->ext
.block
.ns
->code
= body
->next
;
7878 body
->next
= new_st
;
7880 /* Chain in the new list only if it is marked as dangling. Otherwise
7881 there is a CASE label overlap and this is already used. Just ignore,
7882 the error is diagonsed elsewhere. */
7883 if (st
->n
.sym
->assoc
->dangling
)
7885 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
7886 st
->n
.sym
->assoc
->dangling
= 0;
7889 resolve_assoc_var (st
->n
.sym
, false);
7892 /* Take out CLASS IS cases for separate treatment. */
7894 while (body
&& body
->block
)
7896 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
7898 /* Add to class_is list. */
7899 if (class_is
== NULL
)
7901 class_is
= body
->block
;
7906 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
7907 tail
->block
= body
->block
;
7910 /* Remove from EXEC_SELECT list. */
7911 body
->block
= body
->block
->block
;
7924 /* Add a default case to hold the CLASS IS cases. */
7925 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
7926 tail
->block
= gfc_get_code ();
7928 tail
->op
= EXEC_SELECT_TYPE
;
7929 tail
->ext
.block
.case_list
= gfc_get_case ();
7930 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
7932 default_case
= tail
;
7935 /* More than one CLASS IS block? */
7936 if (class_is
->block
)
7940 /* Sort CLASS IS blocks by extension level. */
7944 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
7947 /* F03:C817 (check for doubles). */
7948 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
7949 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
7951 gfc_error ("Double CLASS IS block in SELECT TYPE "
7953 &c2
->ext
.block
.case_list
->where
);
7956 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
7957 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
7960 (*c1
)->block
= c2
->block
;
7970 /* Generate IF chain. */
7971 if_st
= gfc_get_code ();
7972 if_st
->op
= EXEC_IF
;
7974 for (body
= class_is
; body
; body
= body
->block
)
7976 new_st
->block
= gfc_get_code ();
7977 new_st
= new_st
->block
;
7978 new_st
->op
= EXEC_IF
;
7979 /* Set up IF condition: Call _gfortran_is_extension_of. */
7980 new_st
->expr1
= gfc_get_expr ();
7981 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
7982 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
7983 new_st
->expr1
->ts
.kind
= 4;
7984 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
7985 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
7986 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
7987 /* Set up arguments. */
7988 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
7989 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
7990 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
7991 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
7992 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
7993 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
7994 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
7995 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
7996 new_st
->next
= body
->next
;
7998 if (default_case
->next
)
8000 new_st
->block
= gfc_get_code ();
8001 new_st
= new_st
->block
;
8002 new_st
->op
= EXEC_IF
;
8003 new_st
->next
= default_case
->next
;
8006 /* Replace CLASS DEFAULT code by the IF chain. */
8007 default_case
->next
= if_st
;
8010 /* Resolve the internal code. This can not be done earlier because
8011 it requires that the sym->assoc of selectors is set already. */
8012 gfc_current_ns
= ns
;
8013 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8014 gfc_current_ns
= old_ns
;
8016 resolve_select (code
);
8020 /* Resolve a transfer statement. This is making sure that:
8021 -- a derived type being transferred has only non-pointer components
8022 -- a derived type being transferred doesn't have private components, unless
8023 it's being transferred from the module where the type was defined
8024 -- we're not trying to transfer a whole assumed size array. */
8027 resolve_transfer (gfc_code
*code
)
8036 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8037 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8038 exp
= exp
->value
.op
.op1
;
8040 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8041 && exp
->expr_type
!= EXPR_FUNCTION
))
8044 /* If we are reading, the variable will be changed. Note that
8045 code->ext.dt may be NULL if the TRANSFER is related to
8046 an INQUIRE statement -- but in this case, we are not reading, either. */
8047 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8048 && gfc_check_vardef_context (exp
, false, _("item in READ")) == FAILURE
)
8051 sym
= exp
->symtree
->n
.sym
;
8054 /* Go to actual component transferred. */
8055 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8056 if (ref
->type
== REF_COMPONENT
)
8057 ts
= &ref
->u
.c
.component
->ts
;
8059 if (ts
->type
== BT_CLASS
)
8061 /* FIXME: Test for defined input/output. */
8062 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8063 "it is processed by a defined input/output procedure",
8068 if (ts
->type
== BT_DERIVED
)
8070 /* Check that transferred derived type doesn't contain POINTER
8072 if (ts
->u
.derived
->attr
.pointer_comp
)
8074 gfc_error ("Data transfer element at %L cannot have "
8075 "POINTER components", &code
->loc
);
8079 if (ts
->u
.derived
->attr
.alloc_comp
)
8081 gfc_error ("Data transfer element at %L cannot have "
8082 "ALLOCATABLE components", &code
->loc
);
8086 if (derived_inaccessible (ts
->u
.derived
))
8088 gfc_error ("Data transfer element at %L cannot have "
8089 "PRIVATE components",&code
->loc
);
8094 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
8095 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8097 gfc_error ("Data transfer element at %L cannot be a full reference to "
8098 "an assumed-size array", &code
->loc
);
8104 /*********** Toplevel code resolution subroutines ***********/
8106 /* Find the set of labels that are reachable from this block. We also
8107 record the last statement in each block. */
8110 find_reachable_labels (gfc_code
*block
)
8117 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8119 /* Collect labels in this block. We don't keep those corresponding
8120 to END {IF|SELECT}, these are checked in resolve_branch by going
8121 up through the code_stack. */
8122 for (c
= block
; c
; c
= c
->next
)
8124 if (c
->here
&& c
->op
!= EXEC_END_BLOCK
)
8125 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8128 /* Merge with labels from parent block. */
8131 gcc_assert (cs_base
->prev
->reachable_labels
);
8132 bitmap_ior_into (cs_base
->reachable_labels
,
8133 cs_base
->prev
->reachable_labels
);
8139 resolve_sync (gfc_code
*code
)
8141 /* Check imageset. The * case matches expr1 == NULL. */
8144 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8145 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8146 "INTEGER expression", &code
->expr1
->where
);
8147 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8148 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8149 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8150 &code
->expr1
->where
);
8151 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8152 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8154 gfc_constructor
*cons
;
8155 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8156 for (; cons
; cons
= gfc_constructor_next (cons
))
8157 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8158 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8159 gfc_error ("Imageset argument at %L must between 1 and "
8160 "num_images()", &cons
->expr
->where
);
8166 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8167 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8168 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8169 &code
->expr2
->where
);
8173 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8174 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8175 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8176 &code
->expr3
->where
);
8180 /* Given a branch to a label, see if the branch is conforming.
8181 The code node describes where the branch is located. */
8184 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8191 /* Step one: is this a valid branching target? */
8193 if (label
->defined
== ST_LABEL_UNKNOWN
)
8195 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8200 if (label
->defined
!= ST_LABEL_TARGET
)
8202 gfc_error ("Statement at %L is not a valid branch target statement "
8203 "for the branch statement at %L", &label
->where
, &code
->loc
);
8207 /* Step two: make sure this branch is not a branch to itself ;-) */
8209 if (code
->here
== label
)
8211 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8215 /* Step three: See if the label is in the same block as the
8216 branching statement. The hard work has been done by setting up
8217 the bitmap reachable_labels. */
8219 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8221 /* Check now whether there is a CRITICAL construct; if so, check
8222 whether the label is still visible outside of the CRITICAL block,
8223 which is invalid. */
8224 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8225 if (stack
->current
->op
== EXEC_CRITICAL
8226 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8227 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8228 " at %L", &code
->loc
, &label
->where
);
8233 /* Step four: If we haven't found the label in the bitmap, it may
8234 still be the label of the END of the enclosing block, in which
8235 case we find it by going up the code_stack. */
8237 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8239 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8241 if (stack
->current
->op
== EXEC_CRITICAL
)
8243 /* Note: A label at END CRITICAL does not leave the CRITICAL
8244 construct as END CRITICAL is still part of it. */
8245 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8246 " at %L", &code
->loc
, &label
->where
);
8253 gcc_assert (stack
->current
->next
->op
== EXEC_END_BLOCK
);
8257 /* The label is not in an enclosing block, so illegal. This was
8258 allowed in Fortran 66, so we allow it as extension. No
8259 further checks are necessary in this case. */
8260 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8261 "as the GOTO statement at %L", &label
->where
,
8267 /* Check whether EXPR1 has the same shape as EXPR2. */
8270 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8272 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8273 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8274 gfc_try result
= FAILURE
;
8277 /* Compare the rank. */
8278 if (expr1
->rank
!= expr2
->rank
)
8281 /* Compare the size of each dimension. */
8282 for (i
=0; i
<expr1
->rank
; i
++)
8284 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8287 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8290 if (mpz_cmp (shape
[i
], shape2
[i
]))
8294 /* When either of the two expression is an assumed size array, we
8295 ignore the comparison of dimension sizes. */
8300 for (i
--; i
>= 0; i
--)
8302 mpz_clear (shape
[i
]);
8303 mpz_clear (shape2
[i
]);
8309 /* Check whether a WHERE assignment target or a WHERE mask expression
8310 has the same shape as the outmost WHERE mask expression. */
8313 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8319 cblock
= code
->block
;
8321 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8322 In case of nested WHERE, only the outmost one is stored. */
8323 if (mask
== NULL
) /* outmost WHERE */
8325 else /* inner WHERE */
8332 /* Check if the mask-expr has a consistent shape with the
8333 outmost WHERE mask-expr. */
8334 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8335 gfc_error ("WHERE mask at %L has inconsistent shape",
8336 &cblock
->expr1
->where
);
8339 /* the assignment statement of a WHERE statement, or the first
8340 statement in where-body-construct of a WHERE construct */
8341 cnext
= cblock
->next
;
8346 /* WHERE assignment statement */
8349 /* Check shape consistent for WHERE assignment target. */
8350 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8351 gfc_error ("WHERE assignment target at %L has "
8352 "inconsistent shape", &cnext
->expr1
->where
);
8356 case EXEC_ASSIGN_CALL
:
8357 resolve_call (cnext
);
8358 if (!cnext
->resolved_sym
->attr
.elemental
)
8359 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8360 &cnext
->ext
.actual
->expr
->where
);
8363 /* WHERE or WHERE construct is part of a where-body-construct */
8365 resolve_where (cnext
, e
);
8369 gfc_error ("Unsupported statement inside WHERE at %L",
8372 /* the next statement within the same where-body-construct */
8373 cnext
= cnext
->next
;
8375 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8376 cblock
= cblock
->block
;
8381 /* Resolve assignment in FORALL construct.
8382 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8383 FORALL index variables. */
8386 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8390 for (n
= 0; n
< nvar
; n
++)
8392 gfc_symbol
*forall_index
;
8394 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8396 /* Check whether the assignment target is one of the FORALL index
8398 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8399 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8400 gfc_error ("Assignment to a FORALL index variable at %L",
8401 &code
->expr1
->where
);
8404 /* If one of the FORALL index variables doesn't appear in the
8405 assignment variable, then there could be a many-to-one
8406 assignment. Emit a warning rather than an error because the
8407 mask could be resolving this problem. */
8408 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8409 gfc_warning ("The FORALL with index '%s' is not used on the "
8410 "left side of the assignment at %L and so might "
8411 "cause multiple assignment to this object",
8412 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8418 /* Resolve WHERE statement in FORALL construct. */
8421 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8422 gfc_expr
**var_expr
)
8427 cblock
= code
->block
;
8430 /* the assignment statement of a WHERE statement, or the first
8431 statement in where-body-construct of a WHERE construct */
8432 cnext
= cblock
->next
;
8437 /* WHERE assignment statement */
8439 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8442 /* WHERE operator assignment statement */
8443 case EXEC_ASSIGN_CALL
:
8444 resolve_call (cnext
);
8445 if (!cnext
->resolved_sym
->attr
.elemental
)
8446 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8447 &cnext
->ext
.actual
->expr
->where
);
8450 /* WHERE or WHERE construct is part of a where-body-construct */
8452 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8456 gfc_error ("Unsupported statement inside WHERE at %L",
8459 /* the next statement within the same where-body-construct */
8460 cnext
= cnext
->next
;
8462 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8463 cblock
= cblock
->block
;
8468 /* Traverse the FORALL body to check whether the following errors exist:
8469 1. For assignment, check if a many-to-one assignment happens.
8470 2. For WHERE statement, check the WHERE body to see if there is any
8471 many-to-one assignment. */
8474 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8478 c
= code
->block
->next
;
8484 case EXEC_POINTER_ASSIGN
:
8485 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8488 case EXEC_ASSIGN_CALL
:
8492 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8493 there is no need to handle it here. */
8497 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8502 /* The next statement in the FORALL body. */
8508 /* Counts the number of iterators needed inside a forall construct, including
8509 nested forall constructs. This is used to allocate the needed memory
8510 in gfc_resolve_forall. */
8513 gfc_count_forall_iterators (gfc_code
*code
)
8515 int max_iters
, sub_iters
, current_iters
;
8516 gfc_forall_iterator
*fa
;
8518 gcc_assert(code
->op
== EXEC_FORALL
);
8522 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8525 code
= code
->block
->next
;
8529 if (code
->op
== EXEC_FORALL
)
8531 sub_iters
= gfc_count_forall_iterators (code
);
8532 if (sub_iters
> max_iters
)
8533 max_iters
= sub_iters
;
8538 return current_iters
+ max_iters
;
8542 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8543 gfc_resolve_forall_body to resolve the FORALL body. */
8546 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8548 static gfc_expr
**var_expr
;
8549 static int total_var
= 0;
8550 static int nvar
= 0;
8552 gfc_forall_iterator
*fa
;
8557 /* Start to resolve a FORALL construct */
8558 if (forall_save
== 0)
8560 /* Count the total number of FORALL index in the nested FORALL
8561 construct in order to allocate the VAR_EXPR with proper size. */
8562 total_var
= gfc_count_forall_iterators (code
);
8564 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8565 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
8568 /* The information about FORALL iterator, including FORALL index start, end
8569 and stride. The FORALL index can not appear in start, end or stride. */
8570 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8572 /* Check if any outer FORALL index name is the same as the current
8574 for (i
= 0; i
< nvar
; i
++)
8576 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8578 gfc_error ("An outer FORALL construct already has an index "
8579 "with this name %L", &fa
->var
->where
);
8583 /* Record the current FORALL index. */
8584 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8588 /* No memory leak. */
8589 gcc_assert (nvar
<= total_var
);
8592 /* Resolve the FORALL body. */
8593 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8595 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8596 gfc_resolve_blocks (code
->block
, ns
);
8600 /* Free only the VAR_EXPRs allocated in this frame. */
8601 for (i
= nvar
; i
< tmp
; i
++)
8602 gfc_free_expr (var_expr
[i
]);
8606 /* We are in the outermost FORALL construct. */
8607 gcc_assert (forall_save
== 0);
8609 /* VAR_EXPR is not needed any more. */
8610 gfc_free (var_expr
);
8616 /* Resolve a BLOCK construct statement. */
8619 resolve_block_construct (gfc_code
* code
)
8621 /* Resolve the BLOCK's namespace. */
8622 gfc_resolve (code
->ext
.block
.ns
);
8624 /* For an ASSOCIATE block, the associations (and their targets) are already
8625 resolved during resolve_symbol. */
8629 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8632 static void resolve_code (gfc_code
*, gfc_namespace
*);
8635 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8639 for (; b
; b
= b
->block
)
8641 t
= gfc_resolve_expr (b
->expr1
);
8642 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
8648 if (t
== SUCCESS
&& b
->expr1
!= NULL
8649 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8650 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8657 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8658 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8663 resolve_branch (b
->label1
, b
);
8667 resolve_block_construct (b
);
8671 case EXEC_SELECT_TYPE
:
8682 case EXEC_OMP_ATOMIC
:
8683 case EXEC_OMP_CRITICAL
:
8685 case EXEC_OMP_MASTER
:
8686 case EXEC_OMP_ORDERED
:
8687 case EXEC_OMP_PARALLEL
:
8688 case EXEC_OMP_PARALLEL_DO
:
8689 case EXEC_OMP_PARALLEL_SECTIONS
:
8690 case EXEC_OMP_PARALLEL_WORKSHARE
:
8691 case EXEC_OMP_SECTIONS
:
8692 case EXEC_OMP_SINGLE
:
8694 case EXEC_OMP_TASKWAIT
:
8695 case EXEC_OMP_WORKSHARE
:
8699 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8702 resolve_code (b
->next
, ns
);
8707 /* Does everything to resolve an ordinary assignment. Returns true
8708 if this is an interface assignment. */
8710 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
8720 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
8724 if (code
->op
== EXEC_ASSIGN_CALL
)
8726 lhs
= code
->ext
.actual
->expr
;
8727 rhsptr
= &code
->ext
.actual
->next
->expr
;
8731 gfc_actual_arglist
* args
;
8732 gfc_typebound_proc
* tbp
;
8734 gcc_assert (code
->op
== EXEC_COMPCALL
);
8736 args
= code
->expr1
->value
.compcall
.actual
;
8738 rhsptr
= &args
->next
->expr
;
8740 tbp
= code
->expr1
->value
.compcall
.tbp
;
8741 gcc_assert (!tbp
->is_generic
);
8744 /* Make a temporary rhs when there is a default initializer
8745 and rhs is the same symbol as the lhs. */
8746 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
8747 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
8748 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
8749 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
8750 *rhsptr
= gfc_get_parentheses (*rhsptr
);
8759 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
8760 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8761 &code
->loc
) == FAILURE
)
8764 /* Handle the case of a BOZ literal on the RHS. */
8765 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
8768 if (gfc_option
.warn_surprising
)
8769 gfc_warning ("BOZ literal at %L is bitwise transferred "
8770 "non-integer symbol '%s'", &code
->loc
,
8771 lhs
->symtree
->n
.sym
->name
);
8773 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
8775 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
8777 if (rc
== ARITH_UNDERFLOW
)
8778 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8779 ". This check can be disabled with the option "
8780 "-fno-range-check", &rhs
->where
);
8781 else if (rc
== ARITH_OVERFLOW
)
8782 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8783 ". This check can be disabled with the option "
8784 "-fno-range-check", &rhs
->where
);
8785 else if (rc
== ARITH_NAN
)
8786 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8787 ". This check can be disabled with the option "
8788 "-fno-range-check", &rhs
->where
);
8793 if (lhs
->ts
.type
== BT_CHARACTER
8794 && gfc_option
.warn_character_truncation
)
8796 if (lhs
->ts
.u
.cl
!= NULL
8797 && lhs
->ts
.u
.cl
->length
!= NULL
8798 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8799 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
8801 if (rhs
->expr_type
== EXPR_CONSTANT
)
8802 rlen
= rhs
->value
.character
.length
;
8804 else if (rhs
->ts
.u
.cl
!= NULL
8805 && rhs
->ts
.u
.cl
->length
!= NULL
8806 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8807 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
8809 if (rlen
&& llen
&& rlen
> llen
)
8810 gfc_warning_now ("CHARACTER expression will be truncated "
8811 "in assignment (%d/%d) at %L",
8812 llen
, rlen
, &code
->loc
);
8815 /* Ensure that a vector index expression for the lvalue is evaluated
8816 to a temporary if the lvalue symbol is referenced in it. */
8819 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
8820 if (ref
->type
== REF_ARRAY
)
8822 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
8823 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
8824 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
8825 ref
->u
.ar
.start
[n
]))
8827 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
8831 if (gfc_pure (NULL
))
8833 if (lhs
->ts
.type
== BT_DERIVED
8834 && lhs
->expr_type
== EXPR_VARIABLE
8835 && lhs
->ts
.u
.derived
->attr
.pointer_comp
8836 && rhs
->expr_type
== EXPR_VARIABLE
8837 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
8838 || gfc_is_coindexed (rhs
)))
8841 if (gfc_is_coindexed (rhs
))
8842 gfc_error ("Coindexed expression at %L is assigned to "
8843 "a derived type variable with a POINTER "
8844 "component in a PURE procedure",
8847 gfc_error ("The impure variable at %L is assigned to "
8848 "a derived type variable with a POINTER "
8849 "component in a PURE procedure (12.6)",
8854 /* Fortran 2008, C1283. */
8855 if (gfc_is_coindexed (lhs
))
8857 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8858 "procedure", &rhs
->where
);
8863 if (gfc_implicit_pure (NULL
))
8865 if (lhs
->expr_type
== EXPR_VARIABLE
8866 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
8867 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
8868 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
8870 if (lhs
->ts
.type
== BT_DERIVED
8871 && lhs
->expr_type
== EXPR_VARIABLE
8872 && lhs
->ts
.u
.derived
->attr
.pointer_comp
8873 && rhs
->expr_type
== EXPR_VARIABLE
8874 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
8875 || gfc_is_coindexed (rhs
)))
8876 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
8878 /* Fortran 2008, C1283. */
8879 if (gfc_is_coindexed (lhs
))
8880 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
8884 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8885 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8886 if (lhs
->ts
.type
== BT_CLASS
)
8888 gfc_error ("Variable must not be polymorphic in assignment at %L",
8893 /* F2008, Section 7.2.1.2. */
8894 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
8896 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8897 "component in assignment at %L", &lhs
->where
);
8901 gfc_check_assign (lhs
, rhs
, 1);
8906 /* Given a block of code, recursively resolve everything pointed to by this
8910 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
8912 int omp_workshare_save
;
8917 frame
.prev
= cs_base
;
8921 find_reachable_labels (code
);
8923 for (; code
; code
= code
->next
)
8925 frame
.current
= code
;
8926 forall_save
= forall_flag
;
8928 if (code
->op
== EXEC_FORALL
)
8931 gfc_resolve_forall (code
, ns
, forall_save
);
8934 else if (code
->block
)
8936 omp_workshare_save
= -1;
8939 case EXEC_OMP_PARALLEL_WORKSHARE
:
8940 omp_workshare_save
= omp_workshare_flag
;
8941 omp_workshare_flag
= 1;
8942 gfc_resolve_omp_parallel_blocks (code
, ns
);
8944 case EXEC_OMP_PARALLEL
:
8945 case EXEC_OMP_PARALLEL_DO
:
8946 case EXEC_OMP_PARALLEL_SECTIONS
:
8948 omp_workshare_save
= omp_workshare_flag
;
8949 omp_workshare_flag
= 0;
8950 gfc_resolve_omp_parallel_blocks (code
, ns
);
8953 gfc_resolve_omp_do_blocks (code
, ns
);
8955 case EXEC_SELECT_TYPE
:
8956 /* Blocks are handled in resolve_select_type because we have
8957 to transform the SELECT TYPE into ASSOCIATE first. */
8959 case EXEC_OMP_WORKSHARE
:
8960 omp_workshare_save
= omp_workshare_flag
;
8961 omp_workshare_flag
= 1;
8964 gfc_resolve_blocks (code
->block
, ns
);
8968 if (omp_workshare_save
!= -1)
8969 omp_workshare_flag
= omp_workshare_save
;
8973 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
8974 t
= gfc_resolve_expr (code
->expr1
);
8975 forall_flag
= forall_save
;
8977 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
8980 if (code
->op
== EXEC_ALLOCATE
8981 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
8987 case EXEC_END_BLOCK
:
8991 case EXEC_ERROR_STOP
:
8995 case EXEC_ASSIGN_CALL
:
9000 case EXEC_SYNC_IMAGES
:
9001 case EXEC_SYNC_MEMORY
:
9002 resolve_sync (code
);
9006 /* Keep track of which entry we are up to. */
9007 current_entry_id
= code
->ext
.entry
->id
;
9011 resolve_where (code
, NULL
);
9015 if (code
->expr1
!= NULL
)
9017 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9018 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9019 "INTEGER variable", &code
->expr1
->where
);
9020 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9021 gfc_error ("Variable '%s' has not been assigned a target "
9022 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9023 &code
->expr1
->where
);
9026 resolve_branch (code
->label1
, code
);
9030 if (code
->expr1
!= NULL
9031 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9032 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9033 "INTEGER return specifier", &code
->expr1
->where
);
9036 case EXEC_INIT_ASSIGN
:
9037 case EXEC_END_PROCEDURE
:
9044 if (gfc_check_vardef_context (code
->expr1
, false, _("assignment"))
9048 if (resolve_ordinary_assign (code
, ns
))
9050 if (code
->op
== EXEC_COMPCALL
)
9057 case EXEC_LABEL_ASSIGN
:
9058 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9059 gfc_error ("Label %d referenced at %L is never defined",
9060 code
->label1
->value
, &code
->label1
->where
);
9062 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9063 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9064 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9065 != gfc_default_integer_kind
9066 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9067 gfc_error ("ASSIGN statement at %L requires a scalar "
9068 "default INTEGER variable", &code
->expr1
->where
);
9071 case EXEC_POINTER_ASSIGN
:
9078 /* This is both a variable definition and pointer assignment
9079 context, so check both of them. For rank remapping, a final
9080 array ref may be present on the LHS and fool gfc_expr_attr
9081 used in gfc_check_vardef_context. Remove it. */
9082 e
= remove_last_array_ref (code
->expr1
);
9083 t
= gfc_check_vardef_context (e
, true, _("pointer assignment"));
9085 t
= gfc_check_vardef_context (e
, false, _("pointer assignment"));
9090 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9094 case EXEC_ARITHMETIC_IF
:
9096 && code
->expr1
->ts
.type
!= BT_INTEGER
9097 && code
->expr1
->ts
.type
!= BT_REAL
)
9098 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9099 "expression", &code
->expr1
->where
);
9101 resolve_branch (code
->label1
, code
);
9102 resolve_branch (code
->label2
, code
);
9103 resolve_branch (code
->label3
, code
);
9107 if (t
== SUCCESS
&& code
->expr1
!= NULL
9108 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9109 || code
->expr1
->rank
!= 0))
9110 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9111 &code
->expr1
->where
);
9116 resolve_call (code
);
9121 resolve_typebound_subroutine (code
);
9125 resolve_ppc_call (code
);
9129 /* Select is complicated. Also, a SELECT construct could be
9130 a transformed computed GOTO. */
9131 resolve_select (code
);
9134 case EXEC_SELECT_TYPE
:
9135 resolve_select_type (code
, ns
);
9139 resolve_block_construct (code
);
9143 if (code
->ext
.iterator
!= NULL
)
9145 gfc_iterator
*iter
= code
->ext
.iterator
;
9146 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9147 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9152 if (code
->expr1
== NULL
)
9153 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9155 && (code
->expr1
->rank
!= 0
9156 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9157 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9158 "a scalar LOGICAL expression", &code
->expr1
->where
);
9163 resolve_allocate_deallocate (code
, "ALLOCATE");
9167 case EXEC_DEALLOCATE
:
9169 resolve_allocate_deallocate (code
, "DEALLOCATE");
9174 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9177 resolve_branch (code
->ext
.open
->err
, code
);
9181 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9184 resolve_branch (code
->ext
.close
->err
, code
);
9187 case EXEC_BACKSPACE
:
9191 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9194 resolve_branch (code
->ext
.filepos
->err
, code
);
9198 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9201 resolve_branch (code
->ext
.inquire
->err
, code
);
9205 gcc_assert (code
->ext
.inquire
!= NULL
);
9206 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9209 resolve_branch (code
->ext
.inquire
->err
, code
);
9213 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9216 resolve_branch (code
->ext
.wait
->err
, code
);
9217 resolve_branch (code
->ext
.wait
->end
, code
);
9218 resolve_branch (code
->ext
.wait
->eor
, code
);
9223 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9226 resolve_branch (code
->ext
.dt
->err
, code
);
9227 resolve_branch (code
->ext
.dt
->end
, code
);
9228 resolve_branch (code
->ext
.dt
->eor
, code
);
9232 resolve_transfer (code
);
9236 resolve_forall_iterators (code
->ext
.forall_iterator
);
9238 if (code
->expr1
!= NULL
9239 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9240 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9241 "expression", &code
->expr1
->where
);
9244 case EXEC_OMP_ATOMIC
:
9245 case EXEC_OMP_BARRIER
:
9246 case EXEC_OMP_CRITICAL
:
9247 case EXEC_OMP_FLUSH
:
9249 case EXEC_OMP_MASTER
:
9250 case EXEC_OMP_ORDERED
:
9251 case EXEC_OMP_SECTIONS
:
9252 case EXEC_OMP_SINGLE
:
9253 case EXEC_OMP_TASKWAIT
:
9254 case EXEC_OMP_WORKSHARE
:
9255 gfc_resolve_omp_directive (code
, ns
);
9258 case EXEC_OMP_PARALLEL
:
9259 case EXEC_OMP_PARALLEL_DO
:
9260 case EXEC_OMP_PARALLEL_SECTIONS
:
9261 case EXEC_OMP_PARALLEL_WORKSHARE
:
9263 omp_workshare_save
= omp_workshare_flag
;
9264 omp_workshare_flag
= 0;
9265 gfc_resolve_omp_directive (code
, ns
);
9266 omp_workshare_flag
= omp_workshare_save
;
9270 gfc_internal_error ("resolve_code(): Bad statement code");
9274 cs_base
= frame
.prev
;
9278 /* Resolve initial values and make sure they are compatible with
9282 resolve_values (gfc_symbol
*sym
)
9286 if (sym
->value
== NULL
)
9289 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9290 t
= resolve_structure_cons (sym
->value
, 1);
9292 t
= gfc_resolve_expr (sym
->value
);
9297 gfc_check_assign_symbol (sym
, sym
->value
);
9301 /* Verify the binding labels for common blocks that are BIND(C). The label
9302 for a BIND(C) common block must be identical in all scoping units in which
9303 the common block is declared. Further, the binding label can not collide
9304 with any other global entity in the program. */
9307 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9309 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9311 gfc_gsymbol
*binding_label_gsym
;
9312 gfc_gsymbol
*comm_name_gsym
;
9314 /* See if a global symbol exists by the common block's name. It may
9315 be NULL if the common block is use-associated. */
9316 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9317 comm_block_tree
->n
.common
->name
);
9318 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9319 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9320 "with the global entity '%s' at %L",
9321 comm_block_tree
->n
.common
->binding_label
,
9322 comm_block_tree
->n
.common
->name
,
9323 &(comm_block_tree
->n
.common
->where
),
9324 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9325 else if (comm_name_gsym
!= NULL
9326 && strcmp (comm_name_gsym
->name
,
9327 comm_block_tree
->n
.common
->name
) == 0)
9329 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9331 if (comm_name_gsym
->binding_label
== NULL
)
9332 /* No binding label for common block stored yet; save this one. */
9333 comm_name_gsym
->binding_label
=
9334 comm_block_tree
->n
.common
->binding_label
;
9336 if (strcmp (comm_name_gsym
->binding_label
,
9337 comm_block_tree
->n
.common
->binding_label
) != 0)
9339 /* Common block names match but binding labels do not. */
9340 gfc_error ("Binding label '%s' for common block '%s' at %L "
9341 "does not match the binding label '%s' for common "
9343 comm_block_tree
->n
.common
->binding_label
,
9344 comm_block_tree
->n
.common
->name
,
9345 &(comm_block_tree
->n
.common
->where
),
9346 comm_name_gsym
->binding_label
,
9347 comm_name_gsym
->name
,
9348 &(comm_name_gsym
->where
));
9353 /* There is no binding label (NAME="") so we have nothing further to
9354 check and nothing to add as a global symbol for the label. */
9355 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
9358 binding_label_gsym
=
9359 gfc_find_gsymbol (gfc_gsym_root
,
9360 comm_block_tree
->n
.common
->binding_label
);
9361 if (binding_label_gsym
== NULL
)
9363 /* Need to make a global symbol for the binding label to prevent
9364 it from colliding with another. */
9365 binding_label_gsym
=
9366 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9367 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9368 binding_label_gsym
->type
= GSYM_COMMON
;
9372 /* If comm_name_gsym is NULL, the name common block is use
9373 associated and the name could be colliding. */
9374 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9375 gfc_error ("Binding label '%s' for common block '%s' at %L "
9376 "collides with the global entity '%s' at %L",
9377 comm_block_tree
->n
.common
->binding_label
,
9378 comm_block_tree
->n
.common
->name
,
9379 &(comm_block_tree
->n
.common
->where
),
9380 binding_label_gsym
->name
,
9381 &(binding_label_gsym
->where
));
9382 else if (comm_name_gsym
!= NULL
9383 && (strcmp (binding_label_gsym
->name
,
9384 comm_name_gsym
->binding_label
) != 0)
9385 && (strcmp (binding_label_gsym
->sym_name
,
9386 comm_name_gsym
->name
) != 0))
9387 gfc_error ("Binding label '%s' for common block '%s' at %L "
9388 "collides with global entity '%s' at %L",
9389 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9390 &(comm_block_tree
->n
.common
->where
),
9391 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9399 /* Verify any BIND(C) derived types in the namespace so we can report errors
9400 for them once, rather than for each variable declared of that type. */
9403 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9405 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9406 && derived_sym
->attr
.is_bind_c
== 1)
9407 verify_bind_c_derived_type (derived_sym
);
9413 /* Verify that any binding labels used in a given namespace do not collide
9414 with the names or binding labels of any global symbols. */
9417 gfc_verify_binding_labels (gfc_symbol
*sym
)
9421 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9422 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
9424 gfc_gsymbol
*bind_c_sym
;
9426 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9427 if (bind_c_sym
!= NULL
9428 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9430 if (sym
->attr
.if_source
== IFSRC_DECL
9431 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9432 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9433 && ((sym
->attr
.contained
== 1
9434 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9435 || (sym
->attr
.use_assoc
== 1
9436 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9438 /* Make sure global procedures don't collide with anything. */
9439 gfc_error ("Binding label '%s' at %L collides with the global "
9440 "entity '%s' at %L", sym
->binding_label
,
9441 &(sym
->declared_at
), bind_c_sym
->name
,
9442 &(bind_c_sym
->where
));
9445 else if (sym
->attr
.contained
== 0
9446 && (sym
->attr
.if_source
== IFSRC_IFBODY
9447 && sym
->attr
.flavor
== FL_PROCEDURE
)
9448 && (bind_c_sym
->sym_name
!= NULL
9449 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9451 /* Make sure procedures in interface bodies don't collide. */
9452 gfc_error ("Binding label '%s' in interface body at %L collides "
9453 "with the global entity '%s' at %L",
9455 &(sym
->declared_at
), bind_c_sym
->name
,
9456 &(bind_c_sym
->where
));
9459 else if (sym
->attr
.contained
== 0
9460 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9461 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9462 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9463 || sym
->attr
.use_assoc
== 0)
9465 gfc_error ("Binding label '%s' at %L collides with global "
9466 "entity '%s' at %L", sym
->binding_label
,
9467 &(sym
->declared_at
), bind_c_sym
->name
,
9468 &(bind_c_sym
->where
));
9473 /* Clear the binding label to prevent checking multiple times. */
9474 sym
->binding_label
[0] = '\0';
9476 else if (bind_c_sym
== NULL
)
9478 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9479 bind_c_sym
->where
= sym
->declared_at
;
9480 bind_c_sym
->sym_name
= sym
->name
;
9482 if (sym
->attr
.use_assoc
== 1)
9483 bind_c_sym
->mod_name
= sym
->module
;
9485 if (sym
->ns
->proc_name
!= NULL
)
9486 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9488 if (sym
->attr
.contained
== 0)
9490 if (sym
->attr
.subroutine
)
9491 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9492 else if (sym
->attr
.function
)
9493 bind_c_sym
->type
= GSYM_FUNCTION
;
9501 /* Resolve an index expression. */
9504 resolve_index_expr (gfc_expr
*e
)
9506 if (gfc_resolve_expr (e
) == FAILURE
)
9509 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9512 if (gfc_specification_expr (e
) == FAILURE
)
9519 /* Resolve a charlen structure. */
9522 resolve_charlen (gfc_charlen
*cl
)
9531 specification_expr
= 1;
9533 if (resolve_index_expr (cl
->length
) == FAILURE
)
9535 specification_expr
= 0;
9539 /* "If the character length parameter value evaluates to a negative
9540 value, the length of character entities declared is zero." */
9541 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9543 if (gfc_option
.warn_surprising
)
9544 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9545 " the length has been set to zero",
9546 &cl
->length
->where
, i
);
9547 gfc_replace_expr (cl
->length
,
9548 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9551 /* Check that the character length is not too large. */
9552 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9553 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9554 && cl
->length
->ts
.type
== BT_INTEGER
9555 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9557 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9565 /* Test for non-constant shape arrays. */
9568 is_non_constant_shape_array (gfc_symbol
*sym
)
9574 not_constant
= false;
9575 if (sym
->as
!= NULL
)
9577 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9578 has not been simplified; parameter array references. Do the
9579 simplification now. */
9580 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
9582 e
= sym
->as
->lower
[i
];
9583 if (e
&& (resolve_index_expr (e
) == FAILURE
9584 || !gfc_is_constant_expr (e
)))
9585 not_constant
= true;
9586 e
= sym
->as
->upper
[i
];
9587 if (e
&& (resolve_index_expr (e
) == FAILURE
9588 || !gfc_is_constant_expr (e
)))
9589 not_constant
= true;
9592 return not_constant
;
9595 /* Given a symbol and an initialization expression, add code to initialize
9596 the symbol to the function entry. */
9598 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
9602 gfc_namespace
*ns
= sym
->ns
;
9604 /* Search for the function namespace if this is a contained
9605 function without an explicit result. */
9606 if (sym
->attr
.function
&& sym
== sym
->result
9607 && sym
->name
!= sym
->ns
->proc_name
->name
)
9610 for (;ns
; ns
= ns
->sibling
)
9611 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
9617 gfc_free_expr (init
);
9621 /* Build an l-value expression for the result. */
9622 lval
= gfc_lval_expr_from_sym (sym
);
9624 /* Add the code at scope entry. */
9625 init_st
= gfc_get_code ();
9626 init_st
->next
= ns
->code
;
9629 /* Assign the default initializer to the l-value. */
9630 init_st
->loc
= sym
->declared_at
;
9631 init_st
->op
= EXEC_INIT_ASSIGN
;
9632 init_st
->expr1
= lval
;
9633 init_st
->expr2
= init
;
9636 /* Assign the default initializer to a derived type variable or result. */
9639 apply_default_init (gfc_symbol
*sym
)
9641 gfc_expr
*init
= NULL
;
9643 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
9646 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
9647 init
= gfc_default_initializer (&sym
->ts
);
9649 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
9652 build_init_assign (sym
, init
);
9653 sym
->attr
.referenced
= 1;
9656 /* Build an initializer for a local integer, real, complex, logical, or
9657 character variable, based on the command line flags finit-local-zero,
9658 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9659 null if the symbol should not have a default initialization. */
9661 build_default_init_expr (gfc_symbol
*sym
)
9664 gfc_expr
*init_expr
;
9667 /* These symbols should never have a default initialization. */
9668 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
9669 || sym
->attr
.external
9671 || sym
->attr
.pointer
9672 || sym
->attr
.in_equivalence
9673 || sym
->attr
.in_common
9676 || sym
->attr
.cray_pointee
9677 || sym
->attr
.cray_pointer
)
9680 /* Now we'll try to build an initializer expression. */
9681 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
9684 /* We will only initialize integers, reals, complex, logicals, and
9685 characters, and only if the corresponding command-line flags
9686 were set. Otherwise, we free init_expr and return null. */
9687 switch (sym
->ts
.type
)
9690 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
9691 mpz_set_si (init_expr
->value
.integer
,
9692 gfc_option
.flag_init_integer_value
);
9695 gfc_free_expr (init_expr
);
9701 switch (gfc_option
.flag_init_real
)
9703 case GFC_INIT_REAL_SNAN
:
9704 init_expr
->is_snan
= 1;
9706 case GFC_INIT_REAL_NAN
:
9707 mpfr_set_nan (init_expr
->value
.real
);
9710 case GFC_INIT_REAL_INF
:
9711 mpfr_set_inf (init_expr
->value
.real
, 1);
9714 case GFC_INIT_REAL_NEG_INF
:
9715 mpfr_set_inf (init_expr
->value
.real
, -1);
9718 case GFC_INIT_REAL_ZERO
:
9719 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
9723 gfc_free_expr (init_expr
);
9730 switch (gfc_option
.flag_init_real
)
9732 case GFC_INIT_REAL_SNAN
:
9733 init_expr
->is_snan
= 1;
9735 case GFC_INIT_REAL_NAN
:
9736 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
9737 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
9740 case GFC_INIT_REAL_INF
:
9741 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
9742 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
9745 case GFC_INIT_REAL_NEG_INF
:
9746 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
9747 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
9750 case GFC_INIT_REAL_ZERO
:
9751 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
9755 gfc_free_expr (init_expr
);
9762 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
9763 init_expr
->value
.logical
= 0;
9764 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
9765 init_expr
->value
.logical
= 1;
9768 gfc_free_expr (init_expr
);
9774 /* For characters, the length must be constant in order to
9775 create a default initializer. */
9776 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
9777 && sym
->ts
.u
.cl
->length
9778 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9780 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
9781 init_expr
->value
.character
.length
= char_len
;
9782 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
9783 for (i
= 0; i
< char_len
; i
++)
9784 init_expr
->value
.character
.string
[i
]
9785 = (unsigned char) gfc_option
.flag_init_character_value
;
9789 gfc_free_expr (init_expr
);
9795 gfc_free_expr (init_expr
);
9801 /* Add an initialization expression to a local variable. */
9803 apply_default_init_local (gfc_symbol
*sym
)
9805 gfc_expr
*init
= NULL
;
9807 /* The symbol should be a variable or a function return value. */
9808 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
9809 || (sym
->attr
.function
&& sym
->result
!= sym
))
9812 /* Try to build the initializer expression. If we can't initialize
9813 this symbol, then init will be NULL. */
9814 init
= build_default_init_expr (sym
);
9818 /* For saved variables, we don't want to add an initializer at
9819 function entry, so we just add a static initializer. */
9820 if (sym
->attr
.save
|| sym
->ns
->save_all
9821 || gfc_option
.flag_max_stack_var_size
== 0)
9823 /* Don't clobber an existing initializer! */
9824 gcc_assert (sym
->value
== NULL
);
9829 build_init_assign (sym
, init
);
9833 /* Resolution of common features of flavors variable and procedure. */
9836 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
9838 /* Constraints on deferred shape variable. */
9839 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
9841 if (sym
->attr
.allocatable
)
9843 if (sym
->attr
.dimension
)
9845 gfc_error ("Allocatable array '%s' at %L must have "
9846 "a deferred shape", sym
->name
, &sym
->declared_at
);
9849 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
9850 "may not be ALLOCATABLE", sym
->name
,
9851 &sym
->declared_at
) == FAILURE
)
9855 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
9857 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9858 sym
->name
, &sym
->declared_at
);
9864 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
9865 && !sym
->attr
.dummy
&& sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
9867 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9868 sym
->name
, &sym
->declared_at
);
9873 /* Constraints on polymorphic variables. */
9874 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
9877 if (sym
->attr
.class_ok
9878 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
9880 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9881 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
9887 /* Assume that use associated symbols were checked in the module ns.
9888 Class-variables that are associate-names are also something special
9889 and excepted from the test. */
9890 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
9892 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9893 "or pointer", sym
->name
, &sym
->declared_at
);
9902 /* Additional checks for symbols with flavor variable and derived
9903 type. To be called from resolve_fl_variable. */
9906 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
9908 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
9910 /* Check to see if a derived type is blocked from being host
9911 associated by the presence of another class I symbol in the same
9912 namespace. 14.6.1.3 of the standard and the discussion on
9913 comp.lang.fortran. */
9914 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
9915 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
9918 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
9919 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
9921 gfc_error ("The type '%s' cannot be host associated at %L "
9922 "because it is blocked by an incompatible object "
9923 "of the same name declared at %L",
9924 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
9930 /* 4th constraint in section 11.3: "If an object of a type for which
9931 component-initialization is specified (R429) appears in the
9932 specification-part of a module and does not have the ALLOCATABLE
9933 or POINTER attribute, the object shall have the SAVE attribute."
9935 The check for initializers is performed with
9936 gfc_has_default_initializer because gfc_default_initializer generates
9937 a hidden default for allocatable components. */
9938 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
9939 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
9940 && !sym
->ns
->save_all
&& !sym
->attr
.save
9941 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
9942 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
9943 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
9944 "module variable '%s' at %L, needed due to "
9945 "the default initialization", sym
->name
,
9946 &sym
->declared_at
) == FAILURE
)
9949 /* Assign default initializer. */
9950 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
9951 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
9953 sym
->value
= gfc_default_initializer (&sym
->ts
);
9960 /* Resolve symbols with flavor variable. */
9963 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
9965 int no_init_flag
, automatic_flag
;
9967 const char *auto_save_msg
;
9969 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
9972 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
9975 /* Set this flag to check that variables are parameters of all entries.
9976 This check is effected by the call to gfc_resolve_expr through
9977 is_non_constant_shape_array. */
9978 specification_expr
= 1;
9980 if (sym
->ns
->proc_name
9981 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
9982 || sym
->ns
->proc_name
->attr
.is_main_program
)
9983 && !sym
->attr
.use_assoc
9984 && !sym
->attr
.allocatable
9985 && !sym
->attr
.pointer
9986 && is_non_constant_shape_array (sym
))
9988 /* The shape of a main program or module array needs to be
9990 gfc_error ("The module or main program array '%s' at %L must "
9991 "have constant shape", sym
->name
, &sym
->declared_at
);
9992 specification_expr
= 0;
9996 /* Constraints on deferred type parameter. */
9997 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
9999 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10000 "requires either the pointer or allocatable attribute",
10001 sym
->name
, &sym
->declared_at
);
10005 if (sym
->ts
.type
== BT_CHARACTER
)
10007 /* Make sure that character string variables with assumed length are
10008 dummy arguments. */
10009 e
= sym
->ts
.u
.cl
->length
;
10010 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10011 && !sym
->ts
.deferred
)
10013 gfc_error ("Entity with assumed character length at %L must be a "
10014 "dummy argument or a PARAMETER", &sym
->declared_at
);
10018 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10020 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10024 if (!gfc_is_constant_expr (e
)
10025 && !(e
->expr_type
== EXPR_VARIABLE
10026 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
10027 && sym
->ns
->proc_name
10028 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10029 || sym
->ns
->proc_name
->attr
.is_main_program
)
10030 && !sym
->attr
.use_assoc
)
10032 gfc_error ("'%s' at %L must have constant character length "
10033 "in this context", sym
->name
, &sym
->declared_at
);
10038 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10039 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10041 /* Determine if the symbol may not have an initializer. */
10042 no_init_flag
= automatic_flag
= 0;
10043 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10044 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10046 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10047 && is_non_constant_shape_array (sym
))
10049 no_init_flag
= automatic_flag
= 1;
10051 /* Also, they must not have the SAVE attribute.
10052 SAVE_IMPLICIT is checked below. */
10053 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10055 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10060 /* Ensure that any initializer is simplified. */
10062 gfc_simplify_expr (sym
->value
, 1);
10064 /* Reject illegal initializers. */
10065 if (!sym
->mark
&& sym
->value
)
10067 if (sym
->attr
.allocatable
)
10068 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10069 sym
->name
, &sym
->declared_at
);
10070 else if (sym
->attr
.external
)
10071 gfc_error ("External '%s' at %L cannot have an initializer",
10072 sym
->name
, &sym
->declared_at
);
10073 else if (sym
->attr
.dummy
10074 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10075 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10076 sym
->name
, &sym
->declared_at
);
10077 else if (sym
->attr
.intrinsic
)
10078 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10079 sym
->name
, &sym
->declared_at
);
10080 else if (sym
->attr
.result
)
10081 gfc_error ("Function result '%s' at %L cannot have an initializer",
10082 sym
->name
, &sym
->declared_at
);
10083 else if (automatic_flag
)
10084 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10085 sym
->name
, &sym
->declared_at
);
10087 goto no_init_error
;
10092 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10093 return resolve_fl_variable_derived (sym
, no_init_flag
);
10099 /* Resolve a procedure. */
10102 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10104 gfc_formal_arglist
*arg
;
10106 if (sym
->attr
.function
10107 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10110 if (sym
->ts
.type
== BT_CHARACTER
)
10112 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10114 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10115 && resolve_charlen (cl
) == FAILURE
)
10118 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10119 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10121 gfc_error ("Character-valued statement function '%s' at %L must "
10122 "have constant length", sym
->name
, &sym
->declared_at
);
10127 /* Ensure that derived type for are not of a private type. Internal
10128 module procedures are excluded by 2.2.3.3 - i.e., they are not
10129 externally accessible and can access all the objects accessible in
10131 if (!(sym
->ns
->parent
10132 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10133 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
10135 gfc_interface
*iface
;
10137 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10140 && arg
->sym
->ts
.type
== BT_DERIVED
10141 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10142 && !gfc_check_access (arg
->sym
->ts
.u
.derived
->attr
.access
,
10143 arg
->sym
->ts
.u
.derived
->ns
->default_access
)
10144 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10145 "PRIVATE type and cannot be a dummy argument"
10146 " of '%s', which is PUBLIC at %L",
10147 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10150 /* Stop this message from recurring. */
10151 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10156 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10157 PRIVATE to the containing module. */
10158 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10160 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10163 && arg
->sym
->ts
.type
== BT_DERIVED
10164 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10165 && !gfc_check_access (arg
->sym
->ts
.u
.derived
->attr
.access
,
10166 arg
->sym
->ts
.u
.derived
->ns
->default_access
)
10167 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10168 "'%s' in PUBLIC interface '%s' at %L "
10169 "takes dummy arguments of '%s' which is "
10170 "PRIVATE", iface
->sym
->name
, sym
->name
,
10171 &iface
->sym
->declared_at
,
10172 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10174 /* Stop this message from recurring. */
10175 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10181 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10182 PRIVATE to the containing module. */
10183 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10185 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10188 && arg
->sym
->ts
.type
== BT_DERIVED
10189 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10190 && !gfc_check_access (arg
->sym
->ts
.u
.derived
->attr
.access
,
10191 arg
->sym
->ts
.u
.derived
->ns
->default_access
)
10192 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10193 "'%s' in PUBLIC interface '%s' at %L "
10194 "takes dummy arguments of '%s' which is "
10195 "PRIVATE", iface
->sym
->name
, sym
->name
,
10196 &iface
->sym
->declared_at
,
10197 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10199 /* Stop this message from recurring. */
10200 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10207 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10208 && !sym
->attr
.proc_pointer
)
10210 gfc_error ("Function '%s' at %L cannot have an initializer",
10211 sym
->name
, &sym
->declared_at
);
10215 /* An external symbol may not have an initializer because it is taken to be
10216 a procedure. Exception: Procedure Pointers. */
10217 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10219 gfc_error ("External object '%s' at %L may not have an initializer",
10220 sym
->name
, &sym
->declared_at
);
10224 /* An elemental function is required to return a scalar 12.7.1 */
10225 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10227 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10228 "result", sym
->name
, &sym
->declared_at
);
10229 /* Reset so that the error only occurs once. */
10230 sym
->attr
.elemental
= 0;
10234 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10235 char-len-param shall not be array-valued, pointer-valued, recursive
10236 or pure. ....snip... A character value of * may only be used in the
10237 following ways: (i) Dummy arg of procedure - dummy associates with
10238 actual length; (ii) To declare a named constant; or (iii) External
10239 function - but length must be declared in calling scoping unit. */
10240 if (sym
->attr
.function
10241 && sym
->ts
.type
== BT_CHARACTER
10242 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10244 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10245 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10247 if (sym
->as
&& sym
->as
->rank
)
10248 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10249 "array-valued", sym
->name
, &sym
->declared_at
);
10251 if (sym
->attr
.pointer
)
10252 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10253 "pointer-valued", sym
->name
, &sym
->declared_at
);
10255 if (sym
->attr
.pure
)
10256 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10257 "pure", sym
->name
, &sym
->declared_at
);
10259 if (sym
->attr
.recursive
)
10260 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10261 "recursive", sym
->name
, &sym
->declared_at
);
10266 /* Appendix B.2 of the standard. Contained functions give an
10267 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10268 character length is an F2003 feature. */
10269 if (!sym
->attr
.contained
10270 && gfc_current_form
!= FORM_FIXED
10271 && !sym
->ts
.deferred
)
10272 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10273 "CHARACTER(*) function '%s' at %L",
10274 sym
->name
, &sym
->declared_at
);
10277 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10279 gfc_formal_arglist
*curr_arg
;
10280 int has_non_interop_arg
= 0;
10282 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10283 sym
->common_block
) == FAILURE
)
10285 /* Clear these to prevent looking at them again if there was an
10287 sym
->attr
.is_bind_c
= 0;
10288 sym
->attr
.is_c_interop
= 0;
10289 sym
->ts
.is_c_interop
= 0;
10293 /* So far, no errors have been found. */
10294 sym
->attr
.is_c_interop
= 1;
10295 sym
->ts
.is_c_interop
= 1;
10298 curr_arg
= sym
->formal
;
10299 while (curr_arg
!= NULL
)
10301 /* Skip implicitly typed dummy args here. */
10302 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10303 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10304 /* If something is found to fail, record the fact so we
10305 can mark the symbol for the procedure as not being
10306 BIND(C) to try and prevent multiple errors being
10308 has_non_interop_arg
= 1;
10310 curr_arg
= curr_arg
->next
;
10313 /* See if any of the arguments were not interoperable and if so, clear
10314 the procedure symbol to prevent duplicate error messages. */
10315 if (has_non_interop_arg
!= 0)
10317 sym
->attr
.is_c_interop
= 0;
10318 sym
->ts
.is_c_interop
= 0;
10319 sym
->attr
.is_bind_c
= 0;
10323 if (!sym
->attr
.proc_pointer
)
10325 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10327 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10328 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10331 if (sym
->attr
.intent
)
10333 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10334 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10337 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10339 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10340 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10343 if (sym
->attr
.external
&& sym
->attr
.function
10344 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10345 || sym
->attr
.contained
))
10347 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10348 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10351 if (strcmp ("ppr@", sym
->name
) == 0)
10353 gfc_error ("Procedure pointer result '%s' at %L "
10354 "is missing the pointer attribute",
10355 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10364 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10365 been defined and we now know their defined arguments, check that they fulfill
10366 the requirements of the standard for procedures used as finalizers. */
10369 gfc_resolve_finalizers (gfc_symbol
* derived
)
10371 gfc_finalizer
* list
;
10372 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10373 gfc_try result
= SUCCESS
;
10374 bool seen_scalar
= false;
10376 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10379 /* Walk over the list of finalizer-procedures, check them, and if any one
10380 does not fit in with the standard's definition, print an error and remove
10381 it from the list. */
10382 prev_link
= &derived
->f2k_derived
->finalizers
;
10383 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10389 /* Skip this finalizer if we already resolved it. */
10390 if (list
->proc_tree
)
10392 prev_link
= &(list
->next
);
10396 /* Check this exists and is a SUBROUTINE. */
10397 if (!list
->proc_sym
->attr
.subroutine
)
10399 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10400 list
->proc_sym
->name
, &list
->where
);
10404 /* We should have exactly one argument. */
10405 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10407 gfc_error ("FINAL procedure at %L must have exactly one argument",
10411 arg
= list
->proc_sym
->formal
->sym
;
10413 /* This argument must be of our type. */
10414 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10416 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10417 &arg
->declared_at
, derived
->name
);
10421 /* It must neither be a pointer nor allocatable nor optional. */
10422 if (arg
->attr
.pointer
)
10424 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10425 &arg
->declared_at
);
10428 if (arg
->attr
.allocatable
)
10430 gfc_error ("Argument of FINAL procedure at %L must not be"
10431 " ALLOCATABLE", &arg
->declared_at
);
10434 if (arg
->attr
.optional
)
10436 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10437 &arg
->declared_at
);
10441 /* It must not be INTENT(OUT). */
10442 if (arg
->attr
.intent
== INTENT_OUT
)
10444 gfc_error ("Argument of FINAL procedure at %L must not be"
10445 " INTENT(OUT)", &arg
->declared_at
);
10449 /* Warn if the procedure is non-scalar and not assumed shape. */
10450 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10451 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10452 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10453 " shape argument", &arg
->declared_at
);
10455 /* Check that it does not match in kind and rank with a FINAL procedure
10456 defined earlier. To really loop over the *earlier* declarations,
10457 we need to walk the tail of the list as new ones were pushed at the
10459 /* TODO: Handle kind parameters once they are implemented. */
10460 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10461 for (i
= list
->next
; i
; i
= i
->next
)
10463 /* Argument list might be empty; that is an error signalled earlier,
10464 but we nevertheless continued resolving. */
10465 if (i
->proc_sym
->formal
)
10467 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10468 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10469 if (i_rank
== my_rank
)
10471 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10472 " rank (%d) as '%s'",
10473 list
->proc_sym
->name
, &list
->where
, my_rank
,
10474 i
->proc_sym
->name
);
10480 /* Is this the/a scalar finalizer procedure? */
10481 if (!arg
->as
|| arg
->as
->rank
== 0)
10482 seen_scalar
= true;
10484 /* Find the symtree for this procedure. */
10485 gcc_assert (!list
->proc_tree
);
10486 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10488 prev_link
= &list
->next
;
10491 /* Remove wrong nodes immediately from the list so we don't risk any
10492 troubles in the future when they might fail later expectations. */
10496 *prev_link
= list
->next
;
10497 gfc_free_finalizer (i
);
10500 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10501 were nodes in the list, must have been for arrays. It is surely a good
10502 idea to have a scalar version there if there's something to finalize. */
10503 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
10504 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10505 " defined at %L, suggest also scalar one",
10506 derived
->name
, &derived
->declared_at
);
10508 /* TODO: Remove this error when finalization is finished. */
10509 gfc_error ("Finalization at %L is not yet implemented",
10510 &derived
->declared_at
);
10516 /* Check that it is ok for the typebound procedure proc to override the
10520 check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
10523 const gfc_symbol
* proc_target
;
10524 const gfc_symbol
* old_target
;
10525 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
10526 gfc_formal_arglist
* proc_formal
;
10527 gfc_formal_arglist
* old_formal
;
10529 /* This procedure should only be called for non-GENERIC proc. */
10530 gcc_assert (!proc
->n
.tb
->is_generic
);
10532 /* If the overwritten procedure is GENERIC, this is an error. */
10533 if (old
->n
.tb
->is_generic
)
10535 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10536 old
->name
, &proc
->n
.tb
->where
);
10540 where
= proc
->n
.tb
->where
;
10541 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
10542 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
10544 /* Check that overridden binding is not NON_OVERRIDABLE. */
10545 if (old
->n
.tb
->non_overridable
)
10547 gfc_error ("'%s' at %L overrides a procedure binding declared"
10548 " NON_OVERRIDABLE", proc
->name
, &where
);
10552 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10553 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
10555 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10556 " non-DEFERRED binding", proc
->name
, &where
);
10560 /* If the overridden binding is PURE, the overriding must be, too. */
10561 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
10563 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10564 proc
->name
, &where
);
10568 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10569 is not, the overriding must not be either. */
10570 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
10572 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10573 " ELEMENTAL", proc
->name
, &where
);
10576 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
10578 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10579 " be ELEMENTAL, either", proc
->name
, &where
);
10583 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10585 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
10587 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10588 " SUBROUTINE", proc
->name
, &where
);
10592 /* If the overridden binding is a FUNCTION, the overriding must also be a
10593 FUNCTION and have the same characteristics. */
10594 if (old_target
->attr
.function
)
10596 if (!proc_target
->attr
.function
)
10598 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10599 " FUNCTION", proc
->name
, &where
);
10603 /* FIXME: Do more comprehensive checking (including, for instance, the
10604 rank and array-shape). */
10605 gcc_assert (proc_target
->result
&& old_target
->result
);
10606 if (!gfc_compare_types (&proc_target
->result
->ts
,
10607 &old_target
->result
->ts
))
10609 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10610 " matching result types", proc
->name
, &where
);
10615 /* If the overridden binding is PUBLIC, the overriding one must not be
10617 if (old
->n
.tb
->access
== ACCESS_PUBLIC
10618 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
10620 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10621 " PRIVATE", proc
->name
, &where
);
10625 /* Compare the formal argument lists of both procedures. This is also abused
10626 to find the position of the passed-object dummy arguments of both
10627 bindings as at least the overridden one might not yet be resolved and we
10628 need those positions in the check below. */
10629 proc_pass_arg
= old_pass_arg
= 0;
10630 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
10632 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
10635 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
10636 proc_formal
&& old_formal
;
10637 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
10639 if (proc
->n
.tb
->pass_arg
10640 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
10641 proc_pass_arg
= argpos
;
10642 if (old
->n
.tb
->pass_arg
10643 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
10644 old_pass_arg
= argpos
;
10646 /* Check that the names correspond. */
10647 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
10649 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10650 " to match the corresponding argument of the overridden"
10651 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
10652 old_formal
->sym
->name
);
10656 /* Check that the types correspond if neither is the passed-object
10658 /* FIXME: Do more comprehensive testing here. */
10659 if (proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
10660 && !gfc_compare_types (&proc_formal
->sym
->ts
, &old_formal
->sym
->ts
))
10662 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10663 "in respect to the overridden procedure",
10664 proc_formal
->sym
->name
, proc
->name
, &where
);
10670 if (proc_formal
|| old_formal
)
10672 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10673 " the overridden procedure", proc
->name
, &where
);
10677 /* If the overridden binding is NOPASS, the overriding one must also be
10679 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
10681 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10682 " NOPASS", proc
->name
, &where
);
10686 /* If the overridden binding is PASS(x), the overriding one must also be
10687 PASS and the passed-object dummy arguments must correspond. */
10688 if (!old
->n
.tb
->nopass
)
10690 if (proc
->n
.tb
->nopass
)
10692 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10693 " PASS", proc
->name
, &where
);
10697 if (proc_pass_arg
!= old_pass_arg
)
10699 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10700 " the same position as the passed-object dummy argument of"
10701 " the overridden procedure", proc
->name
, &where
);
10710 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10713 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
10714 const char* generic_name
, locus where
)
10719 gcc_assert (t1
->specific
&& t2
->specific
);
10720 gcc_assert (!t1
->specific
->is_generic
);
10721 gcc_assert (!t2
->specific
->is_generic
);
10723 sym1
= t1
->specific
->u
.specific
->n
.sym
;
10724 sym2
= t2
->specific
->u
.specific
->n
.sym
;
10729 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10730 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
10731 || sym1
->attr
.function
!= sym2
->attr
.function
)
10733 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10734 " GENERIC '%s' at %L",
10735 sym1
->name
, sym2
->name
, generic_name
, &where
);
10739 /* Compare the interfaces. */
10740 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, 1, 0, NULL
, 0))
10742 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10743 sym1
->name
, sym2
->name
, generic_name
, &where
);
10751 /* Worker function for resolving a generic procedure binding; this is used to
10752 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10754 The difference between those cases is finding possible inherited bindings
10755 that are overridden, as one has to look for them in tb_sym_root,
10756 tb_uop_root or tb_op, respectively. Thus the caller must already find
10757 the super-type and set p->overridden correctly. */
10760 resolve_tb_generic_targets (gfc_symbol
* super_type
,
10761 gfc_typebound_proc
* p
, const char* name
)
10763 gfc_tbp_generic
* target
;
10764 gfc_symtree
* first_target
;
10765 gfc_symtree
* inherited
;
10767 gcc_assert (p
&& p
->is_generic
);
10769 /* Try to find the specific bindings for the symtrees in our target-list. */
10770 gcc_assert (p
->u
.generic
);
10771 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10772 if (!target
->specific
)
10774 gfc_typebound_proc
* overridden_tbp
;
10775 gfc_tbp_generic
* g
;
10776 const char* target_name
;
10778 target_name
= target
->specific_st
->name
;
10780 /* Defined for this type directly. */
10781 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
10783 target
->specific
= target
->specific_st
->n
.tb
;
10784 goto specific_found
;
10787 /* Look for an inherited specific binding. */
10790 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
10795 gcc_assert (inherited
->n
.tb
);
10796 target
->specific
= inherited
->n
.tb
;
10797 goto specific_found
;
10801 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10802 " at %L", target_name
, name
, &p
->where
);
10805 /* Once we've found the specific binding, check it is not ambiguous with
10806 other specifics already found or inherited for the same GENERIC. */
10808 gcc_assert (target
->specific
);
10810 /* This must really be a specific binding! */
10811 if (target
->specific
->is_generic
)
10813 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10814 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
10818 /* Check those already resolved on this type directly. */
10819 for (g
= p
->u
.generic
; g
; g
= g
->next
)
10820 if (g
!= target
&& g
->specific
10821 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
10825 /* Check for ambiguity with inherited specific targets. */
10826 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
10827 overridden_tbp
= overridden_tbp
->overridden
)
10828 if (overridden_tbp
->is_generic
)
10830 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
10832 gcc_assert (g
->specific
);
10833 if (check_generic_tbp_ambiguity (target
, g
,
10834 name
, p
->where
) == FAILURE
)
10840 /* If we attempt to "overwrite" a specific binding, this is an error. */
10841 if (p
->overridden
&& !p
->overridden
->is_generic
)
10843 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10844 " the same name", name
, &p
->where
);
10848 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10849 all must have the same attributes here. */
10850 first_target
= p
->u
.generic
->specific
->u
.specific
;
10851 gcc_assert (first_target
);
10852 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
10853 p
->function
= first_target
->n
.sym
->attr
.function
;
10859 /* Resolve a GENERIC procedure binding for a derived type. */
10862 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
10864 gfc_symbol
* super_type
;
10866 /* Find the overridden binding if any. */
10867 st
->n
.tb
->overridden
= NULL
;
10868 super_type
= gfc_get_derived_super_type (derived
);
10871 gfc_symtree
* overridden
;
10872 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
10875 if (overridden
&& overridden
->n
.tb
)
10876 st
->n
.tb
->overridden
= overridden
->n
.tb
;
10879 /* Resolve using worker function. */
10880 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
10884 /* Retrieve the target-procedure of an operator binding and do some checks in
10885 common for intrinsic and user-defined type-bound operators. */
10888 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
10890 gfc_symbol
* target_proc
;
10892 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
10893 target_proc
= target
->specific
->u
.specific
->n
.sym
;
10894 gcc_assert (target_proc
);
10896 /* All operator bindings must have a passed-object dummy argument. */
10897 if (target
->specific
->nopass
)
10899 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
10903 return target_proc
;
10907 /* Resolve a type-bound intrinsic operator. */
10910 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
10911 gfc_typebound_proc
* p
)
10913 gfc_symbol
* super_type
;
10914 gfc_tbp_generic
* target
;
10916 /* If there's already an error here, do nothing (but don't fail again). */
10920 /* Operators should always be GENERIC bindings. */
10921 gcc_assert (p
->is_generic
);
10923 /* Look for an overridden binding. */
10924 super_type
= gfc_get_derived_super_type (derived
);
10925 if (super_type
&& super_type
->f2k_derived
)
10926 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
10929 p
->overridden
= NULL
;
10931 /* Resolve general GENERIC properties using worker function. */
10932 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
10935 /* Check the targets to be procedures of correct interface. */
10936 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10938 gfc_symbol
* target_proc
;
10940 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
10944 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
10956 /* Resolve a type-bound user operator (tree-walker callback). */
10958 static gfc_symbol
* resolve_bindings_derived
;
10959 static gfc_try resolve_bindings_result
;
10961 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
10964 resolve_typebound_user_op (gfc_symtree
* stree
)
10966 gfc_symbol
* super_type
;
10967 gfc_tbp_generic
* target
;
10969 gcc_assert (stree
&& stree
->n
.tb
);
10971 if (stree
->n
.tb
->error
)
10974 /* Operators should always be GENERIC bindings. */
10975 gcc_assert (stree
->n
.tb
->is_generic
);
10977 /* Find overridden procedure, if any. */
10978 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
10979 if (super_type
&& super_type
->f2k_derived
)
10981 gfc_symtree
* overridden
;
10982 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
10983 stree
->name
, true, NULL
);
10985 if (overridden
&& overridden
->n
.tb
)
10986 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
10989 stree
->n
.tb
->overridden
= NULL
;
10991 /* Resolve basically using worker function. */
10992 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
10996 /* Check the targets to be functions of correct interface. */
10997 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
10999 gfc_symbol
* target_proc
;
11001 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11005 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11012 resolve_bindings_result
= FAILURE
;
11013 stree
->n
.tb
->error
= 1;
11017 /* Resolve the type-bound procedures for a derived type. */
11020 resolve_typebound_procedure (gfc_symtree
* stree
)
11024 gfc_symbol
* me_arg
;
11025 gfc_symbol
* super_type
;
11026 gfc_component
* comp
;
11028 gcc_assert (stree
);
11030 /* Undefined specific symbol from GENERIC target definition. */
11034 if (stree
->n
.tb
->error
)
11037 /* If this is a GENERIC binding, use that routine. */
11038 if (stree
->n
.tb
->is_generic
)
11040 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11046 /* Get the target-procedure to check it. */
11047 gcc_assert (!stree
->n
.tb
->is_generic
);
11048 gcc_assert (stree
->n
.tb
->u
.specific
);
11049 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11050 where
= stree
->n
.tb
->where
;
11052 /* Default access should already be resolved from the parser. */
11053 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11055 /* It should be a module procedure or an external procedure with explicit
11056 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11057 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11058 || (proc
->attr
.proc
!= PROC_MODULE
11059 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11060 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11062 gfc_error ("'%s' must be a module procedure or an external procedure with"
11063 " an explicit interface at %L", proc
->name
, &where
);
11066 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11067 stree
->n
.tb
->function
= proc
->attr
.function
;
11069 /* Find the super-type of the current derived type. We could do this once and
11070 store in a global if speed is needed, but as long as not I believe this is
11071 more readable and clearer. */
11072 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11074 /* If PASS, resolve and check arguments if not already resolved / loaded
11075 from a .mod file. */
11076 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11078 if (stree
->n
.tb
->pass_arg
)
11080 gfc_formal_arglist
* i
;
11082 /* If an explicit passing argument name is given, walk the arg-list
11083 and look for it. */
11086 stree
->n
.tb
->pass_arg_num
= 1;
11087 for (i
= proc
->formal
; i
; i
= i
->next
)
11089 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11094 ++stree
->n
.tb
->pass_arg_num
;
11099 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11101 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11102 stree
->n
.tb
->pass_arg
);
11108 /* Otherwise, take the first one; there should in fact be at least
11110 stree
->n
.tb
->pass_arg_num
= 1;
11113 gfc_error ("Procedure '%s' with PASS at %L must have at"
11114 " least one argument", proc
->name
, &where
);
11117 me_arg
= proc
->formal
->sym
;
11120 /* Now check that the argument-type matches and the passed-object
11121 dummy argument is generally fine. */
11123 gcc_assert (me_arg
);
11125 if (me_arg
->ts
.type
!= BT_CLASS
)
11127 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11128 " at %L", proc
->name
, &where
);
11132 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11133 != resolve_bindings_derived
)
11135 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11136 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11137 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11141 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11142 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11144 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11145 " scalar", proc
->name
, &where
);
11148 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11150 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11151 " be ALLOCATABLE", proc
->name
, &where
);
11154 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11156 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11157 " be POINTER", proc
->name
, &where
);
11162 /* If we are extending some type, check that we don't override a procedure
11163 flagged NON_OVERRIDABLE. */
11164 stree
->n
.tb
->overridden
= NULL
;
11167 gfc_symtree
* overridden
;
11168 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11169 stree
->name
, true, NULL
);
11171 if (overridden
&& overridden
->n
.tb
)
11172 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11174 if (overridden
&& check_typebound_override (stree
, overridden
) == FAILURE
)
11178 /* See if there's a name collision with a component directly in this type. */
11179 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11180 if (!strcmp (comp
->name
, stree
->name
))
11182 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11184 stree
->name
, &where
, resolve_bindings_derived
->name
);
11188 /* Try to find a name collision with an inherited component. */
11189 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11191 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11192 " component of '%s'",
11193 stree
->name
, &where
, resolve_bindings_derived
->name
);
11197 stree
->n
.tb
->error
= 0;
11201 resolve_bindings_result
= FAILURE
;
11202 stree
->n
.tb
->error
= 1;
11207 resolve_typebound_procedures (gfc_symbol
* derived
)
11211 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11214 resolve_bindings_derived
= derived
;
11215 resolve_bindings_result
= SUCCESS
;
11217 /* Make sure the vtab has been generated. */
11218 gfc_find_derived_vtab (derived
);
11220 if (derived
->f2k_derived
->tb_sym_root
)
11221 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11222 &resolve_typebound_procedure
);
11224 if (derived
->f2k_derived
->tb_uop_root
)
11225 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11226 &resolve_typebound_user_op
);
11228 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11230 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11231 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11233 resolve_bindings_result
= FAILURE
;
11236 return resolve_bindings_result
;
11240 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11241 to give all identical derived types the same backend_decl. */
11243 add_dt_to_dt_list (gfc_symbol
*derived
)
11245 gfc_dt_list
*dt_list
;
11247 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11248 if (derived
== dt_list
->derived
)
11251 dt_list
= gfc_get_dt_list ();
11252 dt_list
->next
= gfc_derived_types
;
11253 dt_list
->derived
= derived
;
11254 gfc_derived_types
= dt_list
;
11258 /* Ensure that a derived-type is really not abstract, meaning that every
11259 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11262 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11267 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11269 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11272 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11274 gfc_symtree
* overriding
;
11275 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11278 gcc_assert (overriding
->n
.tb
);
11279 if (overriding
->n
.tb
->deferred
)
11281 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11282 " '%s' is DEFERRED and not overridden",
11283 sub
->name
, &sub
->declared_at
, st
->name
);
11292 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11294 /* The algorithm used here is to recursively travel up the ancestry of sub
11295 and for each ancestor-type, check all bindings. If any of them is
11296 DEFERRED, look it up starting from sub and see if the found (overriding)
11297 binding is not DEFERRED.
11298 This is not the most efficient way to do this, but it should be ok and is
11299 clearer than something sophisticated. */
11301 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11303 if (!ancestor
->attr
.abstract
)
11306 /* Walk bindings of this ancestor. */
11307 if (ancestor
->f2k_derived
)
11310 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11315 /* Find next ancestor type and recurse on it. */
11316 ancestor
= gfc_get_derived_super_type (ancestor
);
11318 return ensure_not_abstract (sub
, ancestor
);
11324 /* Resolve the components of a derived type. */
11327 resolve_fl_derived (gfc_symbol
*sym
)
11329 gfc_symbol
* super_type
;
11332 super_type
= gfc_get_derived_super_type (sym
);
11334 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
11336 /* Fix up incomplete CLASS symbols. */
11337 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
11338 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
11339 if (vptr
->ts
.u
.derived
== NULL
)
11341 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
11343 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
11348 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11350 gfc_error ("As extending type '%s' at %L has a coarray component, "
11351 "parent type '%s' shall also have one", sym
->name
,
11352 &sym
->declared_at
, super_type
->name
);
11356 /* Ensure the extended type gets resolved before we do. */
11357 if (super_type
&& resolve_fl_derived (super_type
) == FAILURE
)
11360 /* An ABSTRACT type must be extensible. */
11361 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11363 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11364 sym
->name
, &sym
->declared_at
);
11368 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
11371 if (c
->attr
.codimension
/* FIXME: c->as check due to PR 43412. */
11372 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11374 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11375 "deferred shape", c
->name
, &c
->loc
);
11380 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11381 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11383 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11384 "shall not be a coarray", c
->name
, &c
->loc
);
11389 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11390 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11391 || c
->attr
.allocatable
))
11393 gfc_error ("Component '%s' at %L with coarray component "
11394 "shall be a nonpointer, nonallocatable scalar",
11400 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11402 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11403 "is not an array pointer", c
->name
, &c
->loc
);
11407 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11409 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11410 gfc_error ("Interface '%s', used by procedure pointer component "
11411 "'%s' at %L, is declared in a later PROCEDURE statement",
11412 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11414 /* Get the attributes from the interface (now resolved). */
11415 if (c
->ts
.interface
->attr
.if_source
11416 || c
->ts
.interface
->attr
.intrinsic
)
11418 gfc_symbol
*ifc
= c
->ts
.interface
;
11420 if (ifc
->formal
&& !ifc
->formal_ns
)
11421 resolve_symbol (ifc
);
11423 if (ifc
->attr
.intrinsic
)
11424 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11428 c
->ts
= ifc
->result
->ts
;
11429 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11430 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11431 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11432 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11437 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11438 c
->attr
.pointer
= ifc
->attr
.pointer
;
11439 c
->attr
.dimension
= ifc
->attr
.dimension
;
11440 c
->as
= gfc_copy_array_spec (ifc
->as
);
11442 c
->ts
.interface
= ifc
;
11443 c
->attr
.function
= ifc
->attr
.function
;
11444 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11445 gfc_copy_formal_args_ppc (c
, ifc
);
11447 c
->attr
.pure
= ifc
->attr
.pure
;
11448 c
->attr
.elemental
= ifc
->attr
.elemental
;
11449 c
->attr
.recursive
= ifc
->attr
.recursive
;
11450 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11451 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11452 /* Replace symbols in array spec. */
11456 for (i
= 0; i
< c
->as
->rank
; i
++)
11458 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11459 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11462 /* Copy char length. */
11463 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11465 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11466 gfc_expr_replace_comp (cl
->length
, c
);
11467 if (cl
->length
&& !cl
->resolved
11468 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11473 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11475 gfc_error ("Interface '%s' of procedure pointer component "
11476 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11481 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11483 /* Since PPCs are not implicitly typed, a PPC without an explicit
11484 interface must be a subroutine. */
11485 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11488 /* Procedure pointer components: Check PASS arg. */
11489 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11490 && !sym
->attr
.vtype
)
11492 gfc_symbol
* me_arg
;
11494 if (c
->tb
->pass_arg
)
11496 gfc_formal_arglist
* i
;
11498 /* If an explicit passing argument name is given, walk the arg-list
11499 and look for it. */
11502 c
->tb
->pass_arg_num
= 1;
11503 for (i
= c
->formal
; i
; i
= i
->next
)
11505 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11510 c
->tb
->pass_arg_num
++;
11515 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11516 "at %L has no argument '%s'", c
->name
,
11517 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11524 /* Otherwise, take the first one; there should in fact be at least
11526 c
->tb
->pass_arg_num
= 1;
11529 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11530 "must have at least one argument",
11535 me_arg
= c
->formal
->sym
;
11538 /* Now check that the argument-type matches. */
11539 gcc_assert (me_arg
);
11540 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11541 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11542 || (me_arg
->ts
.type
== BT_CLASS
11543 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11545 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11546 " the derived type '%s'", me_arg
->name
, c
->name
,
11547 me_arg
->name
, &c
->loc
, sym
->name
);
11552 /* Check for C453. */
11553 if (me_arg
->attr
.dimension
)
11555 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11556 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11562 if (me_arg
->attr
.pointer
)
11564 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11565 "may not have the POINTER attribute", me_arg
->name
,
11566 c
->name
, me_arg
->name
, &c
->loc
);
11571 if (me_arg
->attr
.allocatable
)
11573 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11574 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11575 me_arg
->name
, &c
->loc
);
11580 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11581 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11582 " at %L", c
->name
, &c
->loc
);
11586 /* Check type-spec if this is not the parent-type component. */
11587 if ((!sym
->attr
.extension
|| c
!= sym
->components
) && !sym
->attr
.vtype
11588 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11591 /* If this type is an extension, set the accessibility of the parent
11593 if (super_type
&& c
== sym
->components
11594 && strcmp (super_type
->name
, c
->name
) == 0)
11595 c
->attr
.access
= super_type
->attr
.access
;
11597 /* If this type is an extension, see if this component has the same name
11598 as an inherited type-bound procedure. */
11599 if (super_type
&& !sym
->attr
.is_class
11600 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11602 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11603 " inherited type-bound procedure",
11604 c
->name
, sym
->name
, &c
->loc
);
11608 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11609 && !c
->ts
.deferred
)
11611 if (c
->ts
.u
.cl
->length
== NULL
11612 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11613 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11615 gfc_error ("Character length of component '%s' needs to "
11616 "be a constant specification expression at %L",
11618 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11623 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11624 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11626 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11627 "length must be a POINTER or ALLOCATABLE",
11628 c
->name
, sym
->name
, &c
->loc
);
11632 if (c
->ts
.type
== BT_DERIVED
11633 && sym
->component_access
!= ACCESS_PRIVATE
11634 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
11635 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11636 && !c
->ts
.u
.derived
->attr
.use_assoc
11637 && !gfc_check_access (c
->ts
.u
.derived
->attr
.access
,
11638 c
->ts
.u
.derived
->ns
->default_access
)
11639 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11640 "is a PRIVATE type and cannot be a component of "
11641 "'%s', which is PUBLIC at %L", c
->name
,
11642 sym
->name
, &sym
->declared_at
) == FAILURE
)
11645 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11647 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11648 "type %s", c
->name
, &c
->loc
, sym
->name
);
11652 if (sym
->attr
.sequence
)
11654 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11656 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11657 "not have the SEQUENCE attribute",
11658 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11663 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11664 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11665 && !c
->ts
.u
.derived
->attr
.zero_comp
)
11667 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11668 "that has not been declared", c
->name
, sym
->name
,
11673 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.class_pointer
11674 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
11675 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
11677 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11678 "that has not been declared", c
->name
, sym
->name
,
11684 if (c
->ts
.type
== BT_CLASS
11685 && !(CLASS_DATA (c
)->attr
.class_pointer
11686 || CLASS_DATA (c
)->attr
.allocatable
))
11688 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11689 "or pointer", c
->name
, &c
->loc
);
11693 /* Ensure that all the derived type components are put on the
11694 derived type list; even in formal namespaces, where derived type
11695 pointer components might not have been declared. */
11696 if (c
->ts
.type
== BT_DERIVED
11698 && c
->ts
.u
.derived
->components
11700 && sym
!= c
->ts
.u
.derived
)
11701 add_dt_to_dt_list (c
->ts
.u
.derived
);
11703 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
11704 || c
->attr
.proc_pointer
11705 || c
->attr
.allocatable
)) == FAILURE
)
11709 /* Resolve the type-bound procedures. */
11710 if (resolve_typebound_procedures (sym
) == FAILURE
)
11713 /* Resolve the finalizer procedures. */
11714 if (gfc_resolve_finalizers (sym
) == FAILURE
)
11717 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11718 all DEFERRED bindings are overridden. */
11719 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
11720 && !sym
->attr
.is_class
11721 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
11724 /* Add derived type to the derived type list. */
11725 add_dt_to_dt_list (sym
);
11732 resolve_fl_namelist (gfc_symbol
*sym
)
11737 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11739 /* Check again, the check in match only works if NAMELIST comes
11741 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
11743 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
11744 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11748 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
11749 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11750 "object '%s' with assumed shape in namelist "
11751 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11752 &sym
->declared_at
) == FAILURE
)
11755 if (is_non_constant_shape_array (nl
->sym
)
11756 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11757 "object '%s' with nonconstant shape in namelist "
11758 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11759 &sym
->declared_at
) == FAILURE
)
11762 if (nl
->sym
->ts
.type
== BT_CHARACTER
11763 && (nl
->sym
->ts
.u
.cl
->length
== NULL
11764 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
11765 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11766 "'%s' with nonconstant character length in "
11767 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
11768 &sym
->declared_at
) == FAILURE
)
11771 /* FIXME: Once UDDTIO is implemented, the following can be
11773 if (nl
->sym
->ts
.type
== BT_CLASS
)
11775 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
11776 "polymorphic and requires a defined input/output "
11777 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11781 if (nl
->sym
->ts
.type
== BT_DERIVED
11782 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
11783 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
11785 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11786 "'%s' in namelist '%s' at %L with ALLOCATABLE "
11787 "or POINTER components", nl
->sym
->name
,
11788 sym
->name
, &sym
->declared_at
) == FAILURE
)
11791 /* FIXME: Once UDDTIO is implemented, the following can be
11793 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
11794 "ALLOCATABLE or POINTER components and thus requires "
11795 "a defined input/output procedure", nl
->sym
->name
,
11796 sym
->name
, &sym
->declared_at
);
11801 /* Reject PRIVATE objects in a PUBLIC namelist. */
11802 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
11804 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11806 if (!nl
->sym
->attr
.use_assoc
11807 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
11808 && !gfc_check_access(nl
->sym
->attr
.access
,
11809 nl
->sym
->ns
->default_access
))
11811 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11812 "cannot be member of PUBLIC namelist '%s' at %L",
11813 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11817 /* Types with private components that came here by USE-association. */
11818 if (nl
->sym
->ts
.type
== BT_DERIVED
11819 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
11821 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11822 "components and cannot be member of namelist '%s' at %L",
11823 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11827 /* Types with private components that are defined in the same module. */
11828 if (nl
->sym
->ts
.type
== BT_DERIVED
11829 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
11830 && !gfc_check_access (nl
->sym
->ts
.u
.derived
->attr
.private_comp
11831 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
11832 nl
->sym
->ns
->default_access
))
11834 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11835 "cannot be a member of PUBLIC namelist '%s' at %L",
11836 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11843 /* 14.1.2 A module or internal procedure represent local entities
11844 of the same type as a namelist member and so are not allowed. */
11845 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11847 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
11850 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
11851 if ((nl
->sym
== sym
->ns
->proc_name
)
11853 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
11857 if (nl
->sym
&& nl
->sym
->name
)
11858 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
11859 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
11861 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11862 "attribute in '%s' at %L", nlsym
->name
,
11863 &sym
->declared_at
);
11873 resolve_fl_parameter (gfc_symbol
*sym
)
11875 /* A parameter array's shape needs to be constant. */
11876 if (sym
->as
!= NULL
11877 && (sym
->as
->type
== AS_DEFERRED
11878 || is_non_constant_shape_array (sym
)))
11880 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11881 "or of deferred shape", sym
->name
, &sym
->declared_at
);
11885 /* Make sure a parameter that has been implicitly typed still
11886 matches the implicit type, since PARAMETER statements can precede
11887 IMPLICIT statements. */
11888 if (sym
->attr
.implicit_type
11889 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
11892 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11893 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
11897 /* Make sure the types of derived parameters are consistent. This
11898 type checking is deferred until resolution because the type may
11899 refer to a derived type from the host. */
11900 if (sym
->ts
.type
== BT_DERIVED
11901 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
11903 gfc_error ("Incompatible derived type in PARAMETER at %L",
11904 &sym
->value
->where
);
11911 /* Do anything necessary to resolve a symbol. Right now, we just
11912 assume that an otherwise unknown symbol is a variable. This sort
11913 of thing commonly happens for symbols in module. */
11916 resolve_symbol (gfc_symbol
*sym
)
11918 int check_constant
, mp_flag
;
11919 gfc_symtree
*symtree
;
11920 gfc_symtree
*this_symtree
;
11924 /* Avoid double resolution of function result symbols. */
11925 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
11926 && (sym
->ns
!= gfc_current_ns
))
11929 if (sym
->attr
.flavor
== FL_UNKNOWN
)
11932 /* If we find that a flavorless symbol is an interface in one of the
11933 parent namespaces, find its symtree in this namespace, free the
11934 symbol and set the symtree to point to the interface symbol. */
11935 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
11937 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
11938 if (symtree
&& (symtree
->n
.sym
->generic
||
11939 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
11940 && sym
->ns
->construct_entities
)))
11942 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
11944 gfc_release_symbol (sym
);
11945 symtree
->n
.sym
->refs
++;
11946 this_symtree
->n
.sym
= symtree
->n
.sym
;
11951 /* Otherwise give it a flavor according to such attributes as
11953 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
11954 sym
->attr
.flavor
= FL_VARIABLE
;
11957 sym
->attr
.flavor
= FL_PROCEDURE
;
11958 if (sym
->attr
.dimension
)
11959 sym
->attr
.function
= 1;
11963 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
11964 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
11966 if (sym
->attr
.procedure
&& sym
->ts
.interface
11967 && sym
->attr
.if_source
!= IFSRC_DECL
11968 && resolve_procedure_interface (sym
) == FAILURE
)
11971 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
11972 && (sym
->attr
.procedure
|| sym
->attr
.external
))
11974 if (sym
->attr
.external
)
11975 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
11976 "at %L", &sym
->declared_at
);
11978 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
11979 "at %L", &sym
->declared_at
);
11986 if (sym
->attr
.contiguous
11987 && (!sym
->attr
.dimension
|| (sym
->as
->type
!= AS_ASSUMED_SHAPE
11988 && !sym
->attr
.pointer
)))
11990 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
11991 "array pointer or an assumed-shape array", sym
->name
,
11992 &sym
->declared_at
);
11996 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
11999 /* Symbols that are module procedures with results (functions) have
12000 the types and array specification copied for type checking in
12001 procedures that call them, as well as for saving to a module
12002 file. These symbols can't stand the scrutiny that their results
12004 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12006 /* Make sure that the intrinsic is consistent with its internal
12007 representation. This needs to be done before assigning a default
12008 type to avoid spurious warnings. */
12009 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12010 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12013 /* Resolve associate names. */
12015 resolve_assoc_var (sym
, true);
12017 /* Assign default type to symbols that need one and don't have one. */
12018 if (sym
->ts
.type
== BT_UNKNOWN
)
12020 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12021 gfc_set_default_type (sym
, 1, NULL
);
12023 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12024 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12025 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12026 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12028 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12030 /* The specific case of an external procedure should emit an error
12031 in the case that there is no implicit type. */
12033 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12036 /* Result may be in another namespace. */
12037 resolve_symbol (sym
->result
);
12039 if (!sym
->result
->attr
.proc_pointer
)
12041 sym
->ts
= sym
->result
->ts
;
12042 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12043 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12044 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12045 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12046 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12052 /* Assumed size arrays and assumed shape arrays must be dummy
12053 arguments. Array-spec's of implied-shape should have been resolved to
12054 AS_EXPLICIT already. */
12058 gcc_assert (sym
->as
->type
!= AS_IMPLIED_SHAPE
);
12059 if (((sym
->as
->type
== AS_ASSUMED_SIZE
&& !sym
->as
->cp_was_assumed
)
12060 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
12061 && sym
->attr
.dummy
== 0)
12063 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
12064 gfc_error ("Assumed size array at %L must be a dummy argument",
12065 &sym
->declared_at
);
12067 gfc_error ("Assumed shape array at %L must be a dummy argument",
12068 &sym
->declared_at
);
12073 /* Make sure symbols with known intent or optional are really dummy
12074 variable. Because of ENTRY statement, this has to be deferred
12075 until resolution time. */
12077 if (!sym
->attr
.dummy
12078 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12080 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12084 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12086 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12087 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12091 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12093 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12094 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12096 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12097 "attribute must have constant length",
12098 sym
->name
, &sym
->declared_at
);
12102 if (sym
->ts
.is_c_interop
12103 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12105 gfc_error ("C interoperable character dummy variable '%s' at %L "
12106 "with VALUE attribute must have length one",
12107 sym
->name
, &sym
->declared_at
);
12112 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12113 do this for something that was implicitly typed because that is handled
12114 in gfc_set_default_type. Handle dummy arguments and procedure
12115 definitions separately. Also, anything that is use associated is not
12116 handled here but instead is handled in the module it is declared in.
12117 Finally, derived type definitions are allowed to be BIND(C) since that
12118 only implies that they're interoperable, and they are checked fully for
12119 interoperability when a variable is declared of that type. */
12120 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12121 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12122 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12124 gfc_try t
= SUCCESS
;
12126 /* First, make sure the variable is declared at the
12127 module-level scope (J3/04-007, Section 15.3). */
12128 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12129 sym
->attr
.in_common
== 0)
12131 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12132 "is neither a COMMON block nor declared at the "
12133 "module level scope", sym
->name
, &(sym
->declared_at
));
12136 else if (sym
->common_head
!= NULL
)
12138 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12142 /* If type() declaration, we need to verify that the components
12143 of the given type are all C interoperable, etc. */
12144 if (sym
->ts
.type
== BT_DERIVED
&&
12145 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12147 /* Make sure the user marked the derived type as BIND(C). If
12148 not, call the verify routine. This could print an error
12149 for the derived type more than once if multiple variables
12150 of that type are declared. */
12151 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12152 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12156 /* Verify the variable itself as C interoperable if it
12157 is BIND(C). It is not possible for this to succeed if
12158 the verify_bind_c_derived_type failed, so don't have to handle
12159 any error returned by verify_bind_c_derived_type. */
12160 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12161 sym
->common_block
);
12166 /* clear the is_bind_c flag to prevent reporting errors more than
12167 once if something failed. */
12168 sym
->attr
.is_bind_c
= 0;
12173 /* If a derived type symbol has reached this point, without its
12174 type being declared, we have an error. Notice that most
12175 conditions that produce undefined derived types have already
12176 been dealt with. However, the likes of:
12177 implicit type(t) (t) ..... call foo (t) will get us here if
12178 the type is not declared in the scope of the implicit
12179 statement. Change the type to BT_UNKNOWN, both because it is so
12180 and to prevent an ICE. */
12181 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->components
== NULL
12182 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12184 gfc_error ("The derived type '%s' at %L is of type '%s', "
12185 "which has not been defined", sym
->name
,
12186 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12187 sym
->ts
.type
= BT_UNKNOWN
;
12191 /* Make sure that the derived type has been resolved and that the
12192 derived type is visible in the symbol's namespace, if it is a
12193 module function and is not PRIVATE. */
12194 if (sym
->ts
.type
== BT_DERIVED
12195 && sym
->ts
.u
.derived
->attr
.use_assoc
12196 && sym
->ns
->proc_name
12197 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12201 if (resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12204 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 1, &ds
);
12205 if (!ds
&& sym
->attr
.function
12206 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
12208 symtree
= gfc_new_symtree (&sym
->ns
->sym_root
,
12209 sym
->ts
.u
.derived
->name
);
12210 symtree
->n
.sym
= sym
->ts
.u
.derived
;
12211 sym
->ts
.u
.derived
->refs
++;
12215 /* Unless the derived-type declaration is use associated, Fortran 95
12216 does not allow public entries of private derived types.
12217 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12218 161 in 95-006r3. */
12219 if (sym
->ts
.type
== BT_DERIVED
12220 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12221 && !sym
->ts
.u
.derived
->attr
.use_assoc
12222 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
12223 && !gfc_check_access (sym
->ts
.u
.derived
->attr
.access
,
12224 sym
->ts
.u
.derived
->ns
->default_access
)
12225 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12226 "of PRIVATE derived type '%s'",
12227 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12228 : "variable", sym
->name
, &sym
->declared_at
,
12229 sym
->ts
.u
.derived
->name
) == FAILURE
)
12232 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12233 default initialization is defined (5.1.2.4.4). */
12234 if (sym
->ts
.type
== BT_DERIVED
12236 && sym
->attr
.intent
== INTENT_OUT
12238 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12240 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12242 if (c
->initializer
)
12244 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12245 "ASSUMED SIZE and so cannot have a default initializer",
12246 sym
->name
, &sym
->declared_at
);
12253 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12254 || sym
->attr
.codimension
)
12255 && sym
->attr
.result
)
12256 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12257 "a coarray component", sym
->name
, &sym
->declared_at
);
12260 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12261 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12262 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12263 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12266 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
12267 && (sym
->attr
.codimension
|| sym
->attr
.pointer
|| sym
->attr
.dimension
12268 || sym
->attr
.allocatable
))
12269 gfc_error ("Variable '%s' at %L with coarray component "
12270 "shall be a nonpointer, nonallocatable scalar",
12271 sym
->name
, &sym
->declared_at
);
12273 /* F2008, C526. The function-result case was handled above. */
12274 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12275 || sym
->attr
.codimension
)
12276 && !(sym
->attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12277 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12278 || sym
->ns
->proc_name
->attr
.is_main_program
12279 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12280 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12281 "component and is not ALLOCATABLE, SAVE nor a "
12282 "dummy argument", sym
->name
, &sym
->declared_at
);
12283 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12284 else if (sym
->attr
.codimension
&& !sym
->attr
.allocatable
12285 && sym
->as
&& sym
->as
->cotype
== AS_DEFERRED
)
12286 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12287 "deferred shape", sym
->name
, &sym
->declared_at
);
12288 else if (sym
->attr
.codimension
&& sym
->attr
.allocatable
12289 && (sym
->as
->type
!= AS_DEFERRED
|| sym
->as
->cotype
!= AS_DEFERRED
))
12290 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12291 "deferred shape", sym
->name
, &sym
->declared_at
);
12295 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12296 || (sym
->attr
.codimension
&& sym
->attr
.allocatable
))
12297 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12298 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12299 "allocatable coarray or have coarray components",
12300 sym
->name
, &sym
->declared_at
);
12302 if (sym
->attr
.codimension
&& sym
->attr
.dummy
12303 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12304 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12305 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12306 sym
->ns
->proc_name
->name
);
12308 switch (sym
->attr
.flavor
)
12311 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12316 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12321 if (resolve_fl_namelist (sym
) == FAILURE
)
12326 if (resolve_fl_parameter (sym
) == FAILURE
)
12334 /* Resolve array specifier. Check as well some constraints
12335 on COMMON blocks. */
12337 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12339 /* Set the formal_arg_flag so that check_conflict will not throw
12340 an error for host associated variables in the specification
12341 expression for an array_valued function. */
12342 if (sym
->attr
.function
&& sym
->as
)
12343 formal_arg_flag
= 1;
12345 gfc_resolve_array_spec (sym
->as
, check_constant
);
12347 formal_arg_flag
= 0;
12349 /* Resolve formal namespaces. */
12350 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12351 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12352 gfc_resolve (sym
->formal_ns
);
12354 /* Make sure the formal namespace is present. */
12355 if (sym
->formal
&& !sym
->formal_ns
)
12357 gfc_formal_arglist
*formal
= sym
->formal
;
12358 while (formal
&& !formal
->sym
)
12359 formal
= formal
->next
;
12363 sym
->formal_ns
= formal
->sym
->ns
;
12364 sym
->formal_ns
->refs
++;
12368 /* Check threadprivate restrictions. */
12369 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12370 && (!sym
->attr
.in_common
12371 && sym
->module
== NULL
12372 && (sym
->ns
->proc_name
== NULL
12373 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12374 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12376 /* If we have come this far we can apply default-initializers, as
12377 described in 14.7.5, to those variables that have not already
12378 been assigned one. */
12379 if (sym
->ts
.type
== BT_DERIVED
12380 && sym
->ns
== gfc_current_ns
12382 && !sym
->attr
.allocatable
12383 && !sym
->attr
.alloc_comp
)
12385 symbol_attribute
*a
= &sym
->attr
;
12387 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12388 && !a
->in_common
&& !a
->use_assoc
12389 && (a
->referenced
|| a
->result
)
12390 && !(a
->function
&& sym
!= sym
->result
))
12391 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12392 apply_default_init (sym
);
12395 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12396 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12397 && !CLASS_DATA (sym
)->attr
.class_pointer
12398 && !CLASS_DATA (sym
)->attr
.allocatable
)
12399 apply_default_init (sym
);
12401 /* If this symbol has a type-spec, check it. */
12402 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12403 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12404 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12410 /************* Resolve DATA statements *************/
12414 gfc_data_value
*vnode
;
12420 /* Advance the values structure to point to the next value in the data list. */
12423 next_data_value (void)
12425 while (mpz_cmp_ui (values
.left
, 0) == 0)
12428 if (values
.vnode
->next
== NULL
)
12431 values
.vnode
= values
.vnode
->next
;
12432 mpz_set (values
.left
, values
.vnode
->repeat
);
12440 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12446 ar_type mark
= AR_UNKNOWN
;
12448 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12454 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12458 mpz_init_set_si (offset
, 0);
12461 if (e
->expr_type
!= EXPR_VARIABLE
)
12462 gfc_internal_error ("check_data_variable(): Bad expression");
12464 sym
= e
->symtree
->n
.sym
;
12466 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12468 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12469 sym
->name
, &sym
->declared_at
);
12472 if (e
->ref
== NULL
&& sym
->as
)
12474 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12475 " declaration", sym
->name
, where
);
12479 has_pointer
= sym
->attr
.pointer
;
12481 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12483 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12486 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
12488 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12494 && ref
->type
== REF_ARRAY
12495 && ref
->u
.ar
.type
!= AR_FULL
)
12497 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12498 "be a full array", sym
->name
, where
);
12503 if (e
->rank
== 0 || has_pointer
)
12505 mpz_init_set_ui (size
, 1);
12512 /* Find the array section reference. */
12513 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12515 if (ref
->type
!= REF_ARRAY
)
12517 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12523 /* Set marks according to the reference pattern. */
12524 switch (ref
->u
.ar
.type
)
12532 /* Get the start position of array section. */
12533 gfc_get_section_index (ar
, section_index
, &offset
);
12538 gcc_unreachable ();
12541 if (gfc_array_size (e
, &size
) == FAILURE
)
12543 gfc_error ("Nonconstant array section at %L in DATA statement",
12545 mpz_clear (offset
);
12552 while (mpz_cmp_ui (size
, 0) > 0)
12554 if (next_data_value () == FAILURE
)
12556 gfc_error ("DATA statement at %L has more variables than values",
12562 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
12566 /* If we have more than one element left in the repeat count,
12567 and we have more than one element left in the target variable,
12568 then create a range assignment. */
12569 /* FIXME: Only done for full arrays for now, since array sections
12571 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
12572 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
12576 if (mpz_cmp (size
, values
.left
) >= 0)
12578 mpz_init_set (range
, values
.left
);
12579 mpz_sub (size
, size
, values
.left
);
12580 mpz_set_ui (values
.left
, 0);
12584 mpz_init_set (range
, size
);
12585 mpz_sub (values
.left
, values
.left
, size
);
12586 mpz_set_ui (size
, 0);
12589 t
= gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
12592 mpz_add (offset
, offset
, range
);
12599 /* Assign initial value to symbol. */
12602 mpz_sub_ui (values
.left
, values
.left
, 1);
12603 mpz_sub_ui (size
, size
, 1);
12605 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
12609 if (mark
== AR_FULL
)
12610 mpz_add_ui (offset
, offset
, 1);
12612 /* Modify the array section indexes and recalculate the offset
12613 for next element. */
12614 else if (mark
== AR_SECTION
)
12615 gfc_advance_section (section_index
, ar
, &offset
);
12619 if (mark
== AR_SECTION
)
12621 for (i
= 0; i
< ar
->dimen
; i
++)
12622 mpz_clear (section_index
[i
]);
12626 mpz_clear (offset
);
12632 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
12634 /* Iterate over a list of elements in a DATA statement. */
12637 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
12640 iterator_stack frame
;
12641 gfc_expr
*e
, *start
, *end
, *step
;
12642 gfc_try retval
= SUCCESS
;
12644 mpz_init (frame
.value
);
12647 start
= gfc_copy_expr (var
->iter
.start
);
12648 end
= gfc_copy_expr (var
->iter
.end
);
12649 step
= gfc_copy_expr (var
->iter
.step
);
12651 if (gfc_simplify_expr (start
, 1) == FAILURE
12652 || start
->expr_type
!= EXPR_CONSTANT
)
12654 gfc_error ("start of implied-do loop at %L could not be "
12655 "simplified to a constant value", &start
->where
);
12659 if (gfc_simplify_expr (end
, 1) == FAILURE
12660 || end
->expr_type
!= EXPR_CONSTANT
)
12662 gfc_error ("end of implied-do loop at %L could not be "
12663 "simplified to a constant value", &start
->where
);
12667 if (gfc_simplify_expr (step
, 1) == FAILURE
12668 || step
->expr_type
!= EXPR_CONSTANT
)
12670 gfc_error ("step of implied-do loop at %L could not be "
12671 "simplified to a constant value", &start
->where
);
12676 mpz_set (trip
, end
->value
.integer
);
12677 mpz_sub (trip
, trip
, start
->value
.integer
);
12678 mpz_add (trip
, trip
, step
->value
.integer
);
12680 mpz_div (trip
, trip
, step
->value
.integer
);
12682 mpz_set (frame
.value
, start
->value
.integer
);
12684 frame
.prev
= iter_stack
;
12685 frame
.variable
= var
->iter
.var
->symtree
;
12686 iter_stack
= &frame
;
12688 while (mpz_cmp_ui (trip
, 0) > 0)
12690 if (traverse_data_var (var
->list
, where
) == FAILURE
)
12696 e
= gfc_copy_expr (var
->expr
);
12697 if (gfc_simplify_expr (e
, 1) == FAILURE
)
12704 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
12706 mpz_sub_ui (trip
, trip
, 1);
12710 mpz_clear (frame
.value
);
12713 gfc_free_expr (start
);
12714 gfc_free_expr (end
);
12715 gfc_free_expr (step
);
12717 iter_stack
= frame
.prev
;
12722 /* Type resolve variables in the variable list of a DATA statement. */
12725 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
12729 for (; var
; var
= var
->next
)
12731 if (var
->expr
== NULL
)
12732 t
= traverse_data_list (var
, where
);
12734 t
= check_data_variable (var
, where
);
12744 /* Resolve the expressions and iterators associated with a data statement.
12745 This is separate from the assignment checking because data lists should
12746 only be resolved once. */
12749 resolve_data_variables (gfc_data_variable
*d
)
12751 for (; d
; d
= d
->next
)
12753 if (d
->list
== NULL
)
12755 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
12760 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
12763 if (resolve_data_variables (d
->list
) == FAILURE
)
12772 /* Resolve a single DATA statement. We implement this by storing a pointer to
12773 the value list into static variables, and then recursively traversing the
12774 variables list, expanding iterators and such. */
12777 resolve_data (gfc_data
*d
)
12780 if (resolve_data_variables (d
->var
) == FAILURE
)
12783 values
.vnode
= d
->value
;
12784 if (d
->value
== NULL
)
12785 mpz_set_ui (values
.left
, 0);
12787 mpz_set (values
.left
, d
->value
->repeat
);
12789 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
12792 /* At this point, we better not have any values left. */
12794 if (next_data_value () == SUCCESS
)
12795 gfc_error ("DATA statement at %L has more values than variables",
12800 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12801 accessed by host or use association, is a dummy argument to a pure function,
12802 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12803 is storage associated with any such variable, shall not be used in the
12804 following contexts: (clients of this function). */
12806 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12807 procedure. Returns zero if assignment is OK, nonzero if there is a
12810 gfc_impure_variable (gfc_symbol
*sym
)
12815 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
12818 /* Check if the symbol's ns is inside the pure procedure. */
12819 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
12823 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
12827 proc
= sym
->ns
->proc_name
;
12828 if (sym
->attr
.dummy
&& gfc_pure (proc
)
12829 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
12831 proc
->attr
.function
))
12834 /* TODO: Sort out what can be storage associated, if anything, and include
12835 it here. In principle equivalences should be scanned but it does not
12836 seem to be possible to storage associate an impure variable this way. */
12841 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12842 current namespace is inside a pure procedure. */
12845 gfc_pure (gfc_symbol
*sym
)
12847 symbol_attribute attr
;
12852 /* Check if the current namespace or one of its parents
12853 belongs to a pure procedure. */
12854 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
12856 sym
= ns
->proc_name
;
12860 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
12868 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
12872 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
12873 checks if the current namespace is implicitly pure. Note that this
12874 function returns false for a PURE procedure. */
12877 gfc_implicit_pure (gfc_symbol
*sym
)
12879 symbol_attribute attr
;
12883 /* Check if the current namespace is implicit_pure. */
12884 sym
= gfc_current_ns
->proc_name
;
12888 if (attr
.flavor
== FL_PROCEDURE
12889 && attr
.implicit_pure
&& !attr
.pure
)
12896 return attr
.flavor
== FL_PROCEDURE
&& attr
.implicit_pure
&& !attr
.pure
;
12900 /* Test whether the current procedure is elemental or not. */
12903 gfc_elemental (gfc_symbol
*sym
)
12905 symbol_attribute attr
;
12908 sym
= gfc_current_ns
->proc_name
;
12913 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
12917 /* Warn about unused labels. */
12920 warn_unused_fortran_label (gfc_st_label
*label
)
12925 warn_unused_fortran_label (label
->left
);
12927 if (label
->defined
== ST_LABEL_UNKNOWN
)
12930 switch (label
->referenced
)
12932 case ST_LABEL_UNKNOWN
:
12933 gfc_warning ("Label %d at %L defined but not used", label
->value
,
12937 case ST_LABEL_BAD_TARGET
:
12938 gfc_warning ("Label %d at %L defined but cannot be used",
12939 label
->value
, &label
->where
);
12946 warn_unused_fortran_label (label
->right
);
12950 /* Returns the sequence type of a symbol or sequence. */
12953 sequence_type (gfc_typespec ts
)
12962 if (ts
.u
.derived
->components
== NULL
)
12963 return SEQ_NONDEFAULT
;
12965 result
= sequence_type (ts
.u
.derived
->components
->ts
);
12966 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
12967 if (sequence_type (c
->ts
) != result
)
12973 if (ts
.kind
!= gfc_default_character_kind
)
12974 return SEQ_NONDEFAULT
;
12976 return SEQ_CHARACTER
;
12979 if (ts
.kind
!= gfc_default_integer_kind
)
12980 return SEQ_NONDEFAULT
;
12982 return SEQ_NUMERIC
;
12985 if (!(ts
.kind
== gfc_default_real_kind
12986 || ts
.kind
== gfc_default_double_kind
))
12987 return SEQ_NONDEFAULT
;
12989 return SEQ_NUMERIC
;
12992 if (ts
.kind
!= gfc_default_complex_kind
)
12993 return SEQ_NONDEFAULT
;
12995 return SEQ_NUMERIC
;
12998 if (ts
.kind
!= gfc_default_logical_kind
)
12999 return SEQ_NONDEFAULT
;
13001 return SEQ_NUMERIC
;
13004 return SEQ_NONDEFAULT
;
13009 /* Resolve derived type EQUIVALENCE object. */
13012 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13014 gfc_component
*c
= derived
->components
;
13019 /* Shall not be an object of nonsequence derived type. */
13020 if (!derived
->attr
.sequence
)
13022 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13023 "attribute to be an EQUIVALENCE object", sym
->name
,
13028 /* Shall not have allocatable components. */
13029 if (derived
->attr
.alloc_comp
)
13031 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13032 "components to be an EQUIVALENCE object",sym
->name
,
13037 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13039 gfc_error ("Derived type variable '%s' at %L with default "
13040 "initialization cannot be in EQUIVALENCE with a variable "
13041 "in COMMON", sym
->name
, &e
->where
);
13045 for (; c
; c
= c
->next
)
13047 if (c
->ts
.type
== BT_DERIVED
13048 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13051 /* Shall not be an object of sequence derived type containing a pointer
13052 in the structure. */
13053 if (c
->attr
.pointer
)
13055 gfc_error ("Derived type variable '%s' at %L with pointer "
13056 "component(s) cannot be an EQUIVALENCE object",
13057 sym
->name
, &e
->where
);
13065 /* Resolve equivalence object.
13066 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13067 an allocatable array, an object of nonsequence derived type, an object of
13068 sequence derived type containing a pointer at any level of component
13069 selection, an automatic object, a function name, an entry name, a result
13070 name, a named constant, a structure component, or a subobject of any of
13071 the preceding objects. A substring shall not have length zero. A
13072 derived type shall not have components with default initialization nor
13073 shall two objects of an equivalence group be initialized.
13074 Either all or none of the objects shall have an protected attribute.
13075 The simple constraints are done in symbol.c(check_conflict) and the rest
13076 are implemented here. */
13079 resolve_equivalence (gfc_equiv
*eq
)
13082 gfc_symbol
*first_sym
;
13085 locus
*last_where
= NULL
;
13086 seq_type eq_type
, last_eq_type
;
13087 gfc_typespec
*last_ts
;
13088 int object
, cnt_protected
;
13091 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13093 first_sym
= eq
->expr
->symtree
->n
.sym
;
13097 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13101 e
->ts
= e
->symtree
->n
.sym
->ts
;
13102 /* match_varspec might not know yet if it is seeing
13103 array reference or substring reference, as it doesn't
13105 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13107 gfc_ref
*ref
= e
->ref
;
13108 sym
= e
->symtree
->n
.sym
;
13110 if (sym
->attr
.dimension
)
13112 ref
->u
.ar
.as
= sym
->as
;
13116 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13117 if (e
->ts
.type
== BT_CHARACTER
13119 && ref
->type
== REF_ARRAY
13120 && ref
->u
.ar
.dimen
== 1
13121 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13122 && ref
->u
.ar
.stride
[0] == NULL
)
13124 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13125 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13128 /* Optimize away the (:) reference. */
13129 if (start
== NULL
&& end
== NULL
)
13132 e
->ref
= ref
->next
;
13134 e
->ref
->next
= ref
->next
;
13139 ref
->type
= REF_SUBSTRING
;
13141 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13143 ref
->u
.ss
.start
= start
;
13144 if (end
== NULL
&& e
->ts
.u
.cl
)
13145 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13146 ref
->u
.ss
.end
= end
;
13147 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13154 /* Any further ref is an error. */
13157 gcc_assert (ref
->type
== REF_ARRAY
);
13158 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13164 if (gfc_resolve_expr (e
) == FAILURE
)
13167 sym
= e
->symtree
->n
.sym
;
13169 if (sym
->attr
.is_protected
)
13171 if (cnt_protected
> 0 && cnt_protected
!= object
)
13173 gfc_error ("Either all or none of the objects in the "
13174 "EQUIVALENCE set at %L shall have the "
13175 "PROTECTED attribute",
13180 /* Shall not equivalence common block variables in a PURE procedure. */
13181 if (sym
->ns
->proc_name
13182 && sym
->ns
->proc_name
->attr
.pure
13183 && sym
->attr
.in_common
)
13185 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13186 "object in the pure procedure '%s'",
13187 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13191 /* Shall not be a named constant. */
13192 if (e
->expr_type
== EXPR_CONSTANT
)
13194 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13195 "object", sym
->name
, &e
->where
);
13199 if (e
->ts
.type
== BT_DERIVED
13200 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13203 /* Check that the types correspond correctly:
13205 A numeric sequence structure may be equivalenced to another sequence
13206 structure, an object of default integer type, default real type, double
13207 precision real type, default logical type such that components of the
13208 structure ultimately only become associated to objects of the same
13209 kind. A character sequence structure may be equivalenced to an object
13210 of default character kind or another character sequence structure.
13211 Other objects may be equivalenced only to objects of the same type and
13212 kind parameters. */
13214 /* Identical types are unconditionally OK. */
13215 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13216 goto identical_types
;
13218 last_eq_type
= sequence_type (*last_ts
);
13219 eq_type
= sequence_type (sym
->ts
);
13221 /* Since the pair of objects is not of the same type, mixed or
13222 non-default sequences can be rejected. */
13224 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13225 "statement at %L with different type objects";
13227 && last_eq_type
== SEQ_MIXED
13228 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13230 || (eq_type
== SEQ_MIXED
13231 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13232 &e
->where
) == FAILURE
))
13235 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13236 "statement at %L with objects of different type";
13238 && last_eq_type
== SEQ_NONDEFAULT
13239 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13240 last_where
) == FAILURE
)
13241 || (eq_type
== SEQ_NONDEFAULT
13242 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13243 &e
->where
) == FAILURE
))
13246 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13247 "EQUIVALENCE statement at %L";
13248 if (last_eq_type
== SEQ_CHARACTER
13249 && eq_type
!= SEQ_CHARACTER
13250 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13251 &e
->where
) == FAILURE
)
13254 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13255 "EQUIVALENCE statement at %L";
13256 if (last_eq_type
== SEQ_NUMERIC
13257 && eq_type
!= SEQ_NUMERIC
13258 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13259 &e
->where
) == FAILURE
)
13264 last_where
= &e
->where
;
13269 /* Shall not be an automatic array. */
13270 if (e
->ref
->type
== REF_ARRAY
13271 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13273 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13274 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13281 /* Shall not be a structure component. */
13282 if (r
->type
== REF_COMPONENT
)
13284 gfc_error ("Structure component '%s' at %L cannot be an "
13285 "EQUIVALENCE object",
13286 r
->u
.c
.component
->name
, &e
->where
);
13290 /* A substring shall not have length zero. */
13291 if (r
->type
== REF_SUBSTRING
)
13293 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13295 gfc_error ("Substring at %L has length zero",
13296 &r
->u
.ss
.start
->where
);
13306 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13309 resolve_fntype (gfc_namespace
*ns
)
13311 gfc_entry_list
*el
;
13314 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13317 /* If there are any entries, ns->proc_name is the entry master
13318 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13320 sym
= ns
->entries
->sym
;
13322 sym
= ns
->proc_name
;
13323 if (sym
->result
== sym
13324 && sym
->ts
.type
== BT_UNKNOWN
13325 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13326 && !sym
->attr
.untyped
)
13328 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13329 sym
->name
, &sym
->declared_at
);
13330 sym
->attr
.untyped
= 1;
13333 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13334 && !sym
->attr
.contained
13335 && !gfc_check_access (sym
->ts
.u
.derived
->attr
.access
,
13336 sym
->ts
.u
.derived
->ns
->default_access
)
13337 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
13339 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13340 "%L of PRIVATE type '%s'", sym
->name
,
13341 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13345 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13347 if (el
->sym
->result
== el
->sym
13348 && el
->sym
->ts
.type
== BT_UNKNOWN
13349 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13350 && !el
->sym
->attr
.untyped
)
13352 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13353 el
->sym
->name
, &el
->sym
->declared_at
);
13354 el
->sym
->attr
.untyped
= 1;
13360 /* 12.3.2.1.1 Defined operators. */
13363 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13365 gfc_formal_arglist
*formal
;
13367 if (!sym
->attr
.function
)
13369 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13370 sym
->name
, &where
);
13374 if (sym
->ts
.type
== BT_CHARACTER
13375 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13376 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13377 && sym
->result
->ts
.u
.cl
->length
))
13379 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13380 "character length", sym
->name
, &where
);
13384 formal
= sym
->formal
;
13385 if (!formal
|| !formal
->sym
)
13387 gfc_error ("User operator procedure '%s' at %L must have at least "
13388 "one argument", sym
->name
, &where
);
13392 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13394 gfc_error ("First argument of operator interface at %L must be "
13395 "INTENT(IN)", &where
);
13399 if (formal
->sym
->attr
.optional
)
13401 gfc_error ("First argument of operator interface at %L cannot be "
13402 "optional", &where
);
13406 formal
= formal
->next
;
13407 if (!formal
|| !formal
->sym
)
13410 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13412 gfc_error ("Second argument of operator interface at %L must be "
13413 "INTENT(IN)", &where
);
13417 if (formal
->sym
->attr
.optional
)
13419 gfc_error ("Second argument of operator interface at %L cannot be "
13420 "optional", &where
);
13426 gfc_error ("Operator interface at %L must have, at most, two "
13427 "arguments", &where
);
13435 gfc_resolve_uops (gfc_symtree
*symtree
)
13437 gfc_interface
*itr
;
13439 if (symtree
== NULL
)
13442 gfc_resolve_uops (symtree
->left
);
13443 gfc_resolve_uops (symtree
->right
);
13445 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13446 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13450 /* Examine all of the expressions associated with a program unit,
13451 assign types to all intermediate expressions, make sure that all
13452 assignments are to compatible types and figure out which names
13453 refer to which functions or subroutines. It doesn't check code
13454 block, which is handled by resolve_code. */
13457 resolve_types (gfc_namespace
*ns
)
13463 gfc_namespace
* old_ns
= gfc_current_ns
;
13465 /* Check that all IMPLICIT types are ok. */
13466 if (!ns
->seen_implicit_none
)
13469 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13470 if (ns
->set_flag
[letter
]
13471 && resolve_typespec_used (&ns
->default_type
[letter
],
13472 &ns
->implicit_loc
[letter
],
13477 gfc_current_ns
= ns
;
13479 resolve_entries (ns
);
13481 resolve_common_vars (ns
->blank_common
.head
, false);
13482 resolve_common_blocks (ns
->common_root
);
13484 resolve_contained_functions (ns
);
13486 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13488 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13489 resolve_charlen (cl
);
13491 gfc_traverse_ns (ns
, resolve_symbol
);
13493 resolve_fntype (ns
);
13495 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13497 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13498 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13499 "also be PURE", n
->proc_name
->name
,
13500 &n
->proc_name
->declared_at
);
13506 gfc_check_interfaces (ns
);
13508 gfc_traverse_ns (ns
, resolve_values
);
13514 for (d
= ns
->data
; d
; d
= d
->next
)
13518 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13520 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13522 if (ns
->common_root
!= NULL
)
13523 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
13525 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
13526 resolve_equivalence (eq
);
13528 /* Warn about unused labels. */
13529 if (warn_unused_label
)
13530 warn_unused_fortran_label (ns
->st_labels
);
13532 gfc_resolve_uops (ns
->uop_root
);
13534 gfc_current_ns
= old_ns
;
13538 /* Call resolve_code recursively. */
13541 resolve_codes (gfc_namespace
*ns
)
13544 bitmap_obstack old_obstack
;
13546 if (ns
->resolved
== 1)
13549 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13552 gfc_current_ns
= ns
;
13554 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13555 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
13558 /* Set to an out of range value. */
13559 current_entry_id
= -1;
13561 old_obstack
= labels_obstack
;
13562 bitmap_obstack_initialize (&labels_obstack
);
13564 resolve_code (ns
->code
, ns
);
13566 bitmap_obstack_release (&labels_obstack
);
13567 labels_obstack
= old_obstack
;
13571 /* This function is called after a complete program unit has been compiled.
13572 Its purpose is to examine all of the expressions associated with a program
13573 unit, assign types to all intermediate expressions, make sure that all
13574 assignments are to compatible types and figure out which names refer to
13575 which functions or subroutines. */
13578 gfc_resolve (gfc_namespace
*ns
)
13580 gfc_namespace
*old_ns
;
13581 code_stack
*old_cs_base
;
13587 old_ns
= gfc_current_ns
;
13588 old_cs_base
= cs_base
;
13590 resolve_types (ns
);
13591 resolve_codes (ns
);
13593 gfc_current_ns
= old_ns
;
13594 cs_base
= old_cs_base
;
13597 gfc_run_passes (ns
);