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
);
164 sym
->ts
= ifc
->result
->ts
;
169 sym
->ts
.interface
= ifc
;
170 sym
->attr
.function
= ifc
->attr
.function
;
171 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
172 gfc_copy_formal_args (sym
, ifc
);
174 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
175 sym
->attr
.pointer
= ifc
->attr
.pointer
;
176 sym
->attr
.pure
= ifc
->attr
.pure
;
177 sym
->attr
.elemental
= ifc
->attr
.elemental
;
178 sym
->attr
.dimension
= ifc
->attr
.dimension
;
179 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
180 sym
->attr
.recursive
= ifc
->attr
.recursive
;
181 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
182 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
183 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
184 /* Copy array spec. */
185 sym
->as
= gfc_copy_array_spec (ifc
->as
);
189 for (i
= 0; i
< sym
->as
->rank
; i
++)
191 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
192 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
195 /* Copy char length. */
196 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
198 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
199 gfc_expr_replace_symbols (sym
->ts
.u
.cl
->length
, sym
);
200 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
201 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
205 else if (sym
->ts
.interface
->name
[0] != '\0')
207 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
208 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
216 /* Resolve types of formal argument lists. These have to be done early so that
217 the formal argument lists of module procedures can be copied to the
218 containing module before the individual procedures are resolved
219 individually. We also resolve argument lists of procedures in interface
220 blocks because they are self-contained scoping units.
222 Since a dummy argument cannot be a non-dummy procedure, the only
223 resort left for untyped names are the IMPLICIT types. */
226 resolve_formal_arglist (gfc_symbol
*proc
)
228 gfc_formal_arglist
*f
;
232 if (proc
->result
!= NULL
)
237 if (gfc_elemental (proc
)
238 || sym
->attr
.pointer
|| sym
->attr
.allocatable
239 || (sym
->as
&& sym
->as
->rank
> 0))
241 proc
->attr
.always_explicit
= 1;
242 sym
->attr
.always_explicit
= 1;
247 for (f
= proc
->formal
; f
; f
= f
->next
)
253 /* Alternate return placeholder. */
254 if (gfc_elemental (proc
))
255 gfc_error ("Alternate return specifier in elemental subroutine "
256 "'%s' at %L is not allowed", proc
->name
,
258 if (proc
->attr
.function
)
259 gfc_error ("Alternate return specifier in function "
260 "'%s' at %L is not allowed", proc
->name
,
264 else if (sym
->attr
.procedure
&& sym
->ts
.interface
265 && sym
->attr
.if_source
!= IFSRC_DECL
)
266 resolve_procedure_interface (sym
);
268 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
269 resolve_formal_arglist (sym
);
271 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
273 if (gfc_pure (proc
) && !gfc_pure (sym
))
275 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
276 "also be PURE", sym
->name
, &sym
->declared_at
);
280 if (proc
->attr
.implicit_pure
&& !gfc_pure(sym
))
281 proc
->attr
.implicit_pure
= 0;
283 if (gfc_elemental (proc
))
285 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
286 "procedure", &sym
->declared_at
);
290 if (sym
->attr
.function
291 && sym
->ts
.type
== BT_UNKNOWN
292 && sym
->attr
.intrinsic
)
294 gfc_intrinsic_sym
*isym
;
295 isym
= gfc_find_function (sym
->name
);
296 if (isym
== NULL
|| !isym
->specific
)
298 gfc_error ("Unable to find a specific INTRINSIC procedure "
299 "for the reference '%s' at %L", sym
->name
,
308 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
309 && (!sym
->attr
.function
|| sym
->result
== sym
))
310 gfc_set_default_type (sym
, 1, sym
->ns
);
312 gfc_resolve_array_spec (sym
->as
, 0);
314 /* We can't tell if an array with dimension (:) is assumed or deferred
315 shape until we know if it has the pointer or allocatable attributes.
317 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
318 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
320 sym
->as
->type
= AS_ASSUMED_SHAPE
;
321 for (i
= 0; i
< sym
->as
->rank
; i
++)
322 sym
->as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
,
326 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
327 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
328 || sym
->attr
.optional
)
330 proc
->attr
.always_explicit
= 1;
332 proc
->result
->attr
.always_explicit
= 1;
335 /* If the flavor is unknown at this point, it has to be a variable.
336 A procedure specification would have already set the type. */
338 if (sym
->attr
.flavor
== FL_UNKNOWN
)
339 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
341 if (gfc_pure (proc
) && !sym
->attr
.pointer
342 && sym
->attr
.flavor
!= FL_PROCEDURE
)
344 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
347 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s' "
348 "of pure function '%s' at %L with VALUE "
349 "attribute but without INTENT(IN)", sym
->name
,
350 proc
->name
, &sym
->declared_at
);
352 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
353 "INTENT(IN) or VALUE", sym
->name
, proc
->name
,
357 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
360 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Argument '%s' "
361 "of pure subroutine '%s' at %L with VALUE "
362 "attribute but without INTENT", sym
->name
,
363 proc
->name
, &sym
->declared_at
);
365 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
366 "have its INTENT specified or have the VALUE "
367 "attribute", sym
->name
, proc
->name
, &sym
->declared_at
);
371 if (proc
->attr
.implicit_pure
&& !sym
->attr
.pointer
372 && sym
->attr
.flavor
!= FL_PROCEDURE
)
374 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
375 proc
->attr
.implicit_pure
= 0;
377 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
378 proc
->attr
.implicit_pure
= 0;
381 if (gfc_elemental (proc
))
384 if (sym
->attr
.codimension
)
386 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
387 "procedure", sym
->name
, &sym
->declared_at
);
393 gfc_error ("Argument '%s' of elemental procedure at %L must "
394 "be scalar", sym
->name
, &sym
->declared_at
);
398 if (sym
->attr
.allocatable
)
400 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
401 "have the ALLOCATABLE attribute", sym
->name
,
406 if (sym
->attr
.pointer
)
408 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
409 "have the POINTER attribute", sym
->name
,
414 if (sym
->attr
.flavor
== FL_PROCEDURE
)
416 gfc_error ("Dummy procedure '%s' not allowed in elemental "
417 "procedure '%s' at %L", sym
->name
, proc
->name
,
422 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
424 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
425 "have its INTENT specified", sym
->name
, proc
->name
,
431 /* Each dummy shall be specified to be scalar. */
432 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
436 gfc_error ("Argument '%s' of statement function at %L must "
437 "be scalar", sym
->name
, &sym
->declared_at
);
441 if (sym
->ts
.type
== BT_CHARACTER
)
443 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
444 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
446 gfc_error ("Character-valued argument '%s' of statement "
447 "function at %L must have constant length",
448 sym
->name
, &sym
->declared_at
);
458 /* Work function called when searching for symbols that have argument lists
459 associated with them. */
462 find_arglists (gfc_symbol
*sym
)
464 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
467 resolve_formal_arglist (sym
);
471 /* Given a namespace, resolve all formal argument lists within the namespace.
475 resolve_formal_arglists (gfc_namespace
*ns
)
480 gfc_traverse_ns (ns
, find_arglists
);
485 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
489 /* If this namespace is not a function or an entry master function,
491 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
492 || sym
->attr
.entry_master
)
495 /* Try to find out of what the return type is. */
496 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
498 t
= gfc_set_default_type (sym
->result
, 0, ns
);
500 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
502 if (sym
->result
== sym
)
503 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
504 sym
->name
, &sym
->declared_at
);
505 else if (!sym
->result
->attr
.proc_pointer
)
506 gfc_error ("Result '%s' of contained function '%s' at %L has "
507 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
508 &sym
->result
->declared_at
);
509 sym
->result
->attr
.untyped
= 1;
513 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
514 type, lists the only ways a character length value of * can be used:
515 dummy arguments of procedures, named constants, and function results
516 in external functions. Internal function results and results of module
517 procedures are not on this list, ergo, not permitted. */
519 if (sym
->result
->ts
.type
== BT_CHARACTER
)
521 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
522 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
524 /* See if this is a module-procedure and adapt error message
527 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
528 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
530 gfc_error ("Character-valued %s '%s' at %L must not be"
532 module_proc
? _("module procedure")
533 : _("internal function"),
534 sym
->name
, &sym
->declared_at
);
540 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
541 introduce duplicates. */
544 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
546 gfc_formal_arglist
*f
, *new_arglist
;
549 for (; new_args
!= NULL
; new_args
= new_args
->next
)
551 new_sym
= new_args
->sym
;
552 /* See if this arg is already in the formal argument list. */
553 for (f
= proc
->formal
; f
; f
= f
->next
)
555 if (new_sym
== f
->sym
)
562 /* Add a new argument. Argument order is not important. */
563 new_arglist
= gfc_get_formal_arglist ();
564 new_arglist
->sym
= new_sym
;
565 new_arglist
->next
= proc
->formal
;
566 proc
->formal
= new_arglist
;
571 /* Flag the arguments that are not present in all entries. */
574 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
576 gfc_formal_arglist
*f
, *head
;
579 for (f
= proc
->formal
; f
; f
= f
->next
)
584 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
586 if (new_args
->sym
== f
->sym
)
593 f
->sym
->attr
.not_always_present
= 1;
598 /* Resolve alternate entry points. If a symbol has multiple entry points we
599 create a new master symbol for the main routine, and turn the existing
600 symbol into an entry point. */
603 resolve_entries (gfc_namespace
*ns
)
605 gfc_namespace
*old_ns
;
609 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
610 static int master_count
= 0;
612 if (ns
->proc_name
== NULL
)
615 /* No need to do anything if this procedure doesn't have alternate entry
620 /* We may already have resolved alternate entry points. */
621 if (ns
->proc_name
->attr
.entry_master
)
624 /* If this isn't a procedure something has gone horribly wrong. */
625 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
627 /* Remember the current namespace. */
628 old_ns
= gfc_current_ns
;
632 /* Add the main entry point to the list of entry points. */
633 el
= gfc_get_entry_list ();
634 el
->sym
= ns
->proc_name
;
636 el
->next
= ns
->entries
;
638 ns
->proc_name
->attr
.entry
= 1;
640 /* If it is a module function, it needs to be in the right namespace
641 so that gfc_get_fake_result_decl can gather up the results. The
642 need for this arose in get_proc_name, where these beasts were
643 left in their own namespace, to keep prior references linked to
644 the entry declaration.*/
645 if (ns
->proc_name
->attr
.function
646 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
649 /* Do the same for entries where the master is not a module
650 procedure. These are retained in the module namespace because
651 of the module procedure declaration. */
652 for (el
= el
->next
; el
; el
= el
->next
)
653 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
654 && el
->sym
->attr
.mod_proc
)
658 /* Add an entry statement for it. */
665 /* Create a new symbol for the master function. */
666 /* Give the internal function a unique name (within this file).
667 Also include the function name so the user has some hope of figuring
668 out what is going on. */
669 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
670 master_count
++, ns
->proc_name
->name
);
671 gfc_get_ha_symbol (name
, &proc
);
672 gcc_assert (proc
!= NULL
);
674 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
675 if (ns
->proc_name
->attr
.subroutine
)
676 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
680 gfc_typespec
*ts
, *fts
;
681 gfc_array_spec
*as
, *fas
;
682 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
684 fas
= ns
->entries
->sym
->as
;
685 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
686 fts
= &ns
->entries
->sym
->result
->ts
;
687 if (fts
->type
== BT_UNKNOWN
)
688 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
689 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
691 ts
= &el
->sym
->result
->ts
;
693 as
= as
? as
: el
->sym
->result
->as
;
694 if (ts
->type
== BT_UNKNOWN
)
695 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
697 if (! gfc_compare_types (ts
, fts
)
698 || (el
->sym
->result
->attr
.dimension
699 != ns
->entries
->sym
->result
->attr
.dimension
)
700 || (el
->sym
->result
->attr
.pointer
701 != ns
->entries
->sym
->result
->attr
.pointer
))
703 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
704 && gfc_compare_array_spec (as
, fas
) == 0)
705 gfc_error ("Function %s at %L has entries with mismatched "
706 "array specifications", ns
->entries
->sym
->name
,
707 &ns
->entries
->sym
->declared_at
);
708 /* The characteristics need to match and thus both need to have
709 the same string length, i.e. both len=*, or both len=4.
710 Having both len=<variable> is also possible, but difficult to
711 check at compile time. */
712 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
713 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
714 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
716 && ts
->u
.cl
->length
->expr_type
717 != fts
->u
.cl
->length
->expr_type
)
719 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
720 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
721 fts
->u
.cl
->length
->value
.integer
) != 0)))
722 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
723 "entries returning variables of different "
724 "string lengths", ns
->entries
->sym
->name
,
725 &ns
->entries
->sym
->declared_at
);
730 sym
= ns
->entries
->sym
->result
;
731 /* All result types the same. */
733 if (sym
->attr
.dimension
)
734 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
735 if (sym
->attr
.pointer
)
736 gfc_add_pointer (&proc
->attr
, NULL
);
740 /* Otherwise the result will be passed through a union by
742 proc
->attr
.mixed_entry_master
= 1;
743 for (el
= ns
->entries
; el
; el
= el
->next
)
745 sym
= el
->sym
->result
;
746 if (sym
->attr
.dimension
)
748 if (el
== ns
->entries
)
749 gfc_error ("FUNCTION result %s can't be an array in "
750 "FUNCTION %s at %L", sym
->name
,
751 ns
->entries
->sym
->name
, &sym
->declared_at
);
753 gfc_error ("ENTRY result %s can't be an array in "
754 "FUNCTION %s at %L", sym
->name
,
755 ns
->entries
->sym
->name
, &sym
->declared_at
);
757 else if (sym
->attr
.pointer
)
759 if (el
== ns
->entries
)
760 gfc_error ("FUNCTION result %s can't be a POINTER in "
761 "FUNCTION %s at %L", sym
->name
,
762 ns
->entries
->sym
->name
, &sym
->declared_at
);
764 gfc_error ("ENTRY result %s can't be a POINTER in "
765 "FUNCTION %s at %L", sym
->name
,
766 ns
->entries
->sym
->name
, &sym
->declared_at
);
771 if (ts
->type
== BT_UNKNOWN
)
772 ts
= gfc_get_default_type (sym
->name
, NULL
);
776 if (ts
->kind
== gfc_default_integer_kind
)
780 if (ts
->kind
== gfc_default_real_kind
781 || ts
->kind
== gfc_default_double_kind
)
785 if (ts
->kind
== gfc_default_complex_kind
)
789 if (ts
->kind
== gfc_default_logical_kind
)
793 /* We will issue error elsewhere. */
801 if (el
== ns
->entries
)
802 gfc_error ("FUNCTION result %s can't be of type %s "
803 "in FUNCTION %s at %L", sym
->name
,
804 gfc_typename (ts
), ns
->entries
->sym
->name
,
807 gfc_error ("ENTRY result %s can't be of type %s "
808 "in FUNCTION %s at %L", sym
->name
,
809 gfc_typename (ts
), ns
->entries
->sym
->name
,
816 proc
->attr
.access
= ACCESS_PRIVATE
;
817 proc
->attr
.entry_master
= 1;
819 /* Merge all the entry point arguments. */
820 for (el
= ns
->entries
; el
; el
= el
->next
)
821 merge_argument_lists (proc
, el
->sym
->formal
);
823 /* Check the master formal arguments for any that are not
824 present in all entry points. */
825 for (el
= ns
->entries
; el
; el
= el
->next
)
826 check_argument_lists (proc
, el
->sym
->formal
);
828 /* Use the master function for the function body. */
829 ns
->proc_name
= proc
;
831 /* Finalize the new symbols. */
832 gfc_commit_symbols ();
834 /* Restore the original namespace. */
835 gfc_current_ns
= old_ns
;
839 /* Resolve common variables. */
841 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
843 gfc_symbol
*csym
= sym
;
845 for (; csym
; csym
= csym
->common_next
)
847 if (csym
->value
|| csym
->attr
.data
)
849 if (!csym
->ns
->is_block_data
)
850 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
851 "but only in BLOCK DATA initialization is "
852 "allowed", csym
->name
, &csym
->declared_at
);
853 else if (!named_common
)
854 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
855 "in a blank COMMON but initialization is only "
856 "allowed in named common blocks", csym
->name
,
860 if (csym
->ts
.type
!= BT_DERIVED
)
863 if (!(csym
->ts
.u
.derived
->attr
.sequence
864 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
865 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
866 "has neither the SEQUENCE nor the BIND(C) "
867 "attribute", csym
->name
, &csym
->declared_at
);
868 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
869 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
870 "has an ultimate component that is "
871 "allocatable", csym
->name
, &csym
->declared_at
);
872 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
873 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
874 "may not have default initializer", csym
->name
,
877 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
878 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
882 /* Resolve common blocks. */
884 resolve_common_blocks (gfc_symtree
*common_root
)
888 if (common_root
== NULL
)
891 if (common_root
->left
)
892 resolve_common_blocks (common_root
->left
);
893 if (common_root
->right
)
894 resolve_common_blocks (common_root
->right
);
896 resolve_common_vars (common_root
->n
.common
->head
, true);
898 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
902 if (sym
->attr
.flavor
== FL_PARAMETER
)
903 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
904 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
906 if (sym
->attr
.intrinsic
)
907 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
908 sym
->name
, &common_root
->n
.common
->where
);
909 else if (sym
->attr
.result
910 || gfc_is_function_return_value (sym
, gfc_current_ns
))
911 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
912 "that is also a function result", sym
->name
,
913 &common_root
->n
.common
->where
);
914 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
915 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
916 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
917 "that is also a global procedure", sym
->name
,
918 &common_root
->n
.common
->where
);
922 /* Resolve contained function types. Because contained functions can call one
923 another, they have to be worked out before any of the contained procedures
926 The good news is that if a function doesn't already have a type, the only
927 way it can get one is through an IMPLICIT type or a RESULT variable, because
928 by definition contained functions are contained namespace they're contained
929 in, not in a sibling or parent namespace. */
932 resolve_contained_functions (gfc_namespace
*ns
)
934 gfc_namespace
*child
;
937 resolve_formal_arglists (ns
);
939 for (child
= ns
->contained
; child
; child
= child
->sibling
)
941 /* Resolve alternate entry points first. */
942 resolve_entries (child
);
944 /* Then check function return types. */
945 resolve_contained_fntype (child
->proc_name
, child
);
946 for (el
= child
->entries
; el
; el
= el
->next
)
947 resolve_contained_fntype (el
->sym
, child
);
952 /* Resolve all of the elements of a structure constructor and make sure that
953 the types are correct. The 'init' flag indicates that the given
954 constructor is an initializer. */
957 resolve_structure_cons (gfc_expr
*expr
, int init
)
959 gfc_constructor
*cons
;
966 if (expr
->ts
.type
== BT_DERIVED
)
967 resolve_symbol (expr
->ts
.u
.derived
);
969 cons
= gfc_constructor_first (expr
->value
.constructor
);
970 /* A constructor may have references if it is the result of substituting a
971 parameter variable. In this case we just pull out the component we
974 comp
= expr
->ref
->u
.c
.sym
->components
;
976 comp
= expr
->ts
.u
.derived
->components
;
978 /* See if the user is trying to invoke a structure constructor for one of
979 the iso_c_binding derived types. */
980 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
981 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
982 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
984 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
985 expr
->ts
.u
.derived
->name
, &(expr
->where
));
989 /* Return if structure constructor is c_null_(fun)prt. */
990 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
991 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
992 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
995 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1002 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1008 rank
= comp
->as
? comp
->as
->rank
: 0;
1009 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1010 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1012 gfc_error ("The rank of the element in the derived type "
1013 "constructor at %L does not match that of the "
1014 "component (%d/%d)", &cons
->expr
->where
,
1015 cons
->expr
->rank
, rank
);
1019 /* If we don't have the right type, try to convert it. */
1021 if (!comp
->attr
.proc_pointer
&&
1022 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1025 if (strcmp (comp
->name
, "_extends") == 0)
1027 /* Can afford to be brutal with the _extends initializer.
1028 The derived type can get lost because it is PRIVATE
1029 but it is not usage constrained by the standard. */
1030 cons
->expr
->ts
= comp
->ts
;
1033 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1034 gfc_error ("The element in the derived type constructor at %L, "
1035 "for pointer component '%s', is %s but should be %s",
1036 &cons
->expr
->where
, comp
->name
,
1037 gfc_basic_typename (cons
->expr
->ts
.type
),
1038 gfc_basic_typename (comp
->ts
.type
));
1040 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1043 /* For strings, the length of the constructor should be the same as
1044 the one of the structure, ensure this if the lengths are known at
1045 compile time and when we are dealing with PARAMETER or structure
1047 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1048 && comp
->ts
.u
.cl
->length
1049 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1050 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1051 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1052 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1053 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1055 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1056 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1058 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1059 to make use of the gfc_resolve_character_array_constructor
1060 machinery. The expression is later simplified away to
1061 an array of string literals. */
1062 gfc_expr
*para
= cons
->expr
;
1063 cons
->expr
= gfc_get_expr ();
1064 cons
->expr
->ts
= para
->ts
;
1065 cons
->expr
->where
= para
->where
;
1066 cons
->expr
->expr_type
= EXPR_ARRAY
;
1067 cons
->expr
->rank
= para
->rank
;
1068 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1069 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1070 para
, &cons
->expr
->where
);
1072 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1075 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1076 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1078 gfc_charlen
*cl
, *cl2
;
1081 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1083 if (cl
== cons
->expr
->ts
.u
.cl
)
1091 cl2
->next
= cl
->next
;
1093 gfc_free_expr (cl
->length
);
1097 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1098 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1099 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1100 gfc_resolve_character_array_constructor (cons
->expr
);
1104 if (cons
->expr
->expr_type
== EXPR_NULL
1105 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1106 || comp
->attr
.proc_pointer
1107 || (comp
->ts
.type
== BT_CLASS
1108 && (CLASS_DATA (comp
)->attr
.class_pointer
1109 || CLASS_DATA (comp
)->attr
.allocatable
))))
1112 gfc_error ("The NULL in the derived type constructor at %L is "
1113 "being applied to component '%s', which is neither "
1114 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1118 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1119 || cons
->expr
->expr_type
== EXPR_NULL
)
1122 a
= gfc_expr_attr (cons
->expr
);
1124 if (!a
.pointer
&& !a
.target
)
1127 gfc_error ("The element in the derived type constructor at %L, "
1128 "for pointer component '%s' should be a POINTER or "
1129 "a TARGET", &cons
->expr
->where
, comp
->name
);
1134 /* F08:C461. Additional checks for pointer initialization. */
1138 gfc_error ("Pointer initialization target at %L "
1139 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1144 gfc_error ("Pointer initialization target at %L "
1145 "must have the SAVE attribute", &cons
->expr
->where
);
1149 /* F2003, C1272 (3). */
1150 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1151 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1152 || gfc_is_coindexed (cons
->expr
)))
1155 gfc_error ("Invalid expression in the derived type constructor for "
1156 "pointer component '%s' at %L in PURE procedure",
1157 comp
->name
, &cons
->expr
->where
);
1160 if (gfc_implicit_pure (NULL
)
1161 && cons
->expr
->expr_type
== EXPR_VARIABLE
1162 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1163 || gfc_is_coindexed (cons
->expr
)))
1164 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1172 /****************** Expression name resolution ******************/
1174 /* Returns 0 if a symbol was not declared with a type or
1175 attribute declaration statement, nonzero otherwise. */
1178 was_declared (gfc_symbol
*sym
)
1184 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1187 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1188 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1189 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1190 || a
.asynchronous
|| a
.codimension
)
1197 /* Determine if a symbol is generic or not. */
1200 generic_sym (gfc_symbol
*sym
)
1204 if (sym
->attr
.generic
||
1205 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1208 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1211 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1218 return generic_sym (s
);
1225 /* Determine if a symbol is specific or not. */
1228 specific_sym (gfc_symbol
*sym
)
1232 if (sym
->attr
.if_source
== IFSRC_IFBODY
1233 || sym
->attr
.proc
== PROC_MODULE
1234 || sym
->attr
.proc
== PROC_INTERNAL
1235 || sym
->attr
.proc
== PROC_ST_FUNCTION
1236 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1237 || sym
->attr
.external
)
1240 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1243 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1245 return (s
== NULL
) ? 0 : specific_sym (s
);
1249 /* Figure out if the procedure is specific, generic or unknown. */
1252 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1256 procedure_kind (gfc_symbol
*sym
)
1258 if (generic_sym (sym
))
1259 return PTYPE_GENERIC
;
1261 if (specific_sym (sym
))
1262 return PTYPE_SPECIFIC
;
1264 return PTYPE_UNKNOWN
;
1267 /* Check references to assumed size arrays. The flag need_full_assumed_size
1268 is nonzero when matching actual arguments. */
1270 static int need_full_assumed_size
= 0;
1273 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1275 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1278 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1279 What should it be? */
1280 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1281 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1282 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1284 gfc_error ("The upper bound in the last dimension must "
1285 "appear in the reference to the assumed size "
1286 "array '%s' at %L", sym
->name
, &e
->where
);
1293 /* Look for bad assumed size array references in argument expressions
1294 of elemental and array valued intrinsic procedures. Since this is
1295 called from procedure resolution functions, it only recurses at
1299 resolve_assumed_size_actual (gfc_expr
*e
)
1304 switch (e
->expr_type
)
1307 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1312 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1313 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1324 /* Check a generic procedure, passed as an actual argument, to see if
1325 there is a matching specific name. If none, it is an error, and if
1326 more than one, the reference is ambiguous. */
1328 count_specific_procs (gfc_expr
*e
)
1335 sym
= e
->symtree
->n
.sym
;
1337 for (p
= sym
->generic
; p
; p
= p
->next
)
1338 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1340 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1346 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1350 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1351 "argument at %L", sym
->name
, &e
->where
);
1357 /* See if a call to sym could possibly be a not allowed RECURSION because of
1358 a missing RECURIVE declaration. This means that either sym is the current
1359 context itself, or sym is the parent of a contained procedure calling its
1360 non-RECURSIVE containing procedure.
1361 This also works if sym is an ENTRY. */
1364 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1366 gfc_symbol
* proc_sym
;
1367 gfc_symbol
* context_proc
;
1368 gfc_namespace
* real_context
;
1370 if (sym
->attr
.flavor
== FL_PROGRAM
)
1373 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1375 /* If we've got an ENTRY, find real procedure. */
1376 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1377 proc_sym
= sym
->ns
->entries
->sym
;
1381 /* If sym is RECURSIVE, all is well of course. */
1382 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1385 /* Find the context procedure's "real" symbol if it has entries.
1386 We look for a procedure symbol, so recurse on the parents if we don't
1387 find one (like in case of a BLOCK construct). */
1388 for (real_context
= context
; ; real_context
= real_context
->parent
)
1390 /* We should find something, eventually! */
1391 gcc_assert (real_context
);
1393 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1394 : real_context
->proc_name
);
1396 /* In some special cases, there may not be a proc_name, like for this
1398 real(bad_kind()) function foo () ...
1399 when checking the call to bad_kind ().
1400 In these cases, we simply return here and assume that the
1405 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1409 /* A call from sym's body to itself is recursion, of course. */
1410 if (context_proc
== proc_sym
)
1413 /* The same is true if context is a contained procedure and sym the
1415 if (context_proc
->attr
.contained
)
1417 gfc_symbol
* parent_proc
;
1419 gcc_assert (context
->parent
);
1420 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1421 : context
->parent
->proc_name
);
1423 if (parent_proc
== proc_sym
)
1431 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1432 its typespec and formal argument list. */
1435 resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1437 gfc_intrinsic_sym
* isym
= NULL
;
1443 /* We already know this one is an intrinsic, so we don't call
1444 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1445 gfc_find_subroutine directly to check whether it is a function or
1448 if (sym
->intmod_sym_id
)
1449 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1451 isym
= gfc_find_function (sym
->name
);
1455 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1456 && !sym
->attr
.implicit_type
)
1457 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1458 " ignored", sym
->name
, &sym
->declared_at
);
1460 if (!sym
->attr
.function
&&
1461 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1466 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1468 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1470 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1471 " specifier", sym
->name
, &sym
->declared_at
);
1475 if (!sym
->attr
.subroutine
&&
1476 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1481 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1486 gfc_copy_formal_args_intr (sym
, isym
);
1488 /* Check it is actually available in the standard settings. */
1489 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1492 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1493 " available in the current standard settings but %s. Use"
1494 " an appropriate -std=* option or enable -fall-intrinsics"
1495 " in order to use it.",
1496 sym
->name
, &sym
->declared_at
, symstd
);
1504 /* Resolve a procedure expression, like passing it to a called procedure or as
1505 RHS for a procedure pointer assignment. */
1508 resolve_procedure_expression (gfc_expr
* expr
)
1512 if (expr
->expr_type
!= EXPR_VARIABLE
)
1514 gcc_assert (expr
->symtree
);
1516 sym
= expr
->symtree
->n
.sym
;
1518 if (sym
->attr
.intrinsic
)
1519 resolve_intrinsic (sym
, &expr
->where
);
1521 if (sym
->attr
.flavor
!= FL_PROCEDURE
1522 || (sym
->attr
.function
&& sym
->result
== sym
))
1525 /* A non-RECURSIVE procedure that is used as procedure expression within its
1526 own body is in danger of being called recursively. */
1527 if (is_illegal_recursion (sym
, gfc_current_ns
))
1528 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1529 " itself recursively. Declare it RECURSIVE or use"
1530 " -frecursive", sym
->name
, &expr
->where
);
1536 /* Resolve an actual argument list. Most of the time, this is just
1537 resolving the expressions in the list.
1538 The exception is that we sometimes have to decide whether arguments
1539 that look like procedure arguments are really simple variable
1543 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1544 bool no_formal_args
)
1547 gfc_symtree
*parent_st
;
1549 int save_need_full_assumed_size
;
1551 for (; arg
; arg
= arg
->next
)
1556 /* Check the label is a valid branching target. */
1559 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1561 gfc_error ("Label %d referenced at %L is never defined",
1562 arg
->label
->value
, &arg
->label
->where
);
1569 if (e
->expr_type
== EXPR_VARIABLE
1570 && e
->symtree
->n
.sym
->attr
.generic
1572 && count_specific_procs (e
) != 1)
1575 if (e
->ts
.type
!= BT_PROCEDURE
)
1577 save_need_full_assumed_size
= need_full_assumed_size
;
1578 if (e
->expr_type
!= EXPR_VARIABLE
)
1579 need_full_assumed_size
= 0;
1580 if (gfc_resolve_expr (e
) != SUCCESS
)
1582 need_full_assumed_size
= save_need_full_assumed_size
;
1586 /* See if the expression node should really be a variable reference. */
1588 sym
= e
->symtree
->n
.sym
;
1590 if (sym
->attr
.flavor
== FL_PROCEDURE
1591 || sym
->attr
.intrinsic
1592 || sym
->attr
.external
)
1596 /* If a procedure is not already determined to be something else
1597 check if it is intrinsic. */
1598 if (!sym
->attr
.intrinsic
1599 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1600 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1601 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1602 sym
->attr
.intrinsic
= 1;
1604 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1606 gfc_error ("Statement function '%s' at %L is not allowed as an "
1607 "actual argument", sym
->name
, &e
->where
);
1610 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1611 sym
->attr
.subroutine
);
1612 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1614 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1615 "actual argument", sym
->name
, &e
->where
);
1618 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1619 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1621 if (gfc_notify_std (GFC_STD_F2008
,
1622 "Fortran 2008: Internal procedure '%s' is"
1623 " used as actual argument at %L",
1624 sym
->name
, &e
->where
) == FAILURE
)
1628 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1630 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1631 "allowed as an actual argument at %L", sym
->name
,
1635 /* Check if a generic interface has a specific procedure
1636 with the same name before emitting an error. */
1637 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1640 /* Just in case a specific was found for the expression. */
1641 sym
= e
->symtree
->n
.sym
;
1643 /* If the symbol is the function that names the current (or
1644 parent) scope, then we really have a variable reference. */
1646 if (gfc_is_function_return_value (sym
, sym
->ns
))
1649 /* If all else fails, see if we have a specific intrinsic. */
1650 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1652 gfc_intrinsic_sym
*isym
;
1654 isym
= gfc_find_function (sym
->name
);
1655 if (isym
== NULL
|| !isym
->specific
)
1657 gfc_error ("Unable to find a specific INTRINSIC procedure "
1658 "for the reference '%s' at %L", sym
->name
,
1663 sym
->attr
.intrinsic
= 1;
1664 sym
->attr
.function
= 1;
1667 if (gfc_resolve_expr (e
) == FAILURE
)
1672 /* See if the name is a module procedure in a parent unit. */
1674 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1677 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1679 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1683 if (parent_st
== NULL
)
1686 sym
= parent_st
->n
.sym
;
1687 e
->symtree
= parent_st
; /* Point to the right thing. */
1689 if (sym
->attr
.flavor
== FL_PROCEDURE
1690 || sym
->attr
.intrinsic
1691 || sym
->attr
.external
)
1693 if (gfc_resolve_expr (e
) == FAILURE
)
1699 e
->expr_type
= EXPR_VARIABLE
;
1701 if (sym
->as
!= NULL
)
1703 e
->rank
= sym
->as
->rank
;
1704 e
->ref
= gfc_get_ref ();
1705 e
->ref
->type
= REF_ARRAY
;
1706 e
->ref
->u
.ar
.type
= AR_FULL
;
1707 e
->ref
->u
.ar
.as
= sym
->as
;
1710 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1711 primary.c (match_actual_arg). If above code determines that it
1712 is a variable instead, it needs to be resolved as it was not
1713 done at the beginning of this function. */
1714 save_need_full_assumed_size
= need_full_assumed_size
;
1715 if (e
->expr_type
!= EXPR_VARIABLE
)
1716 need_full_assumed_size
= 0;
1717 if (gfc_resolve_expr (e
) != SUCCESS
)
1719 need_full_assumed_size
= save_need_full_assumed_size
;
1722 /* Check argument list functions %VAL, %LOC and %REF. There is
1723 nothing to do for %REF. */
1724 if (arg
->name
&& arg
->name
[0] == '%')
1726 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1728 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1730 gfc_error ("By-value argument at %L is not of numeric "
1737 gfc_error ("By-value argument at %L cannot be an array or "
1738 "an array section", &e
->where
);
1742 /* Intrinsics are still PROC_UNKNOWN here. However,
1743 since same file external procedures are not resolvable
1744 in gfortran, it is a good deal easier to leave them to
1746 if (ptype
!= PROC_UNKNOWN
1747 && ptype
!= PROC_DUMMY
1748 && ptype
!= PROC_EXTERNAL
1749 && ptype
!= PROC_MODULE
)
1751 gfc_error ("By-value argument at %L is not allowed "
1752 "in this context", &e
->where
);
1757 /* Statement functions have already been excluded above. */
1758 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1759 && e
->ts
.type
== BT_PROCEDURE
)
1761 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1763 gfc_error ("Passing internal procedure at %L by location "
1764 "not allowed", &e
->where
);
1770 /* Fortran 2008, C1237. */
1771 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1772 && gfc_has_ultimate_pointer (e
))
1774 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1775 "component", &e
->where
);
1784 /* Do the checks of the actual argument list that are specific to elemental
1785 procedures. If called with c == NULL, we have a function, otherwise if
1786 expr == NULL, we have a subroutine. */
1789 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1791 gfc_actual_arglist
*arg0
;
1792 gfc_actual_arglist
*arg
;
1793 gfc_symbol
*esym
= NULL
;
1794 gfc_intrinsic_sym
*isym
= NULL
;
1796 gfc_intrinsic_arg
*iformal
= NULL
;
1797 gfc_formal_arglist
*eformal
= NULL
;
1798 bool formal_optional
= false;
1799 bool set_by_optional
= false;
1803 /* Is this an elemental procedure? */
1804 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1806 if (expr
->value
.function
.esym
!= NULL
1807 && expr
->value
.function
.esym
->attr
.elemental
)
1809 arg0
= expr
->value
.function
.actual
;
1810 esym
= expr
->value
.function
.esym
;
1812 else if (expr
->value
.function
.isym
!= NULL
1813 && expr
->value
.function
.isym
->elemental
)
1815 arg0
= expr
->value
.function
.actual
;
1816 isym
= expr
->value
.function
.isym
;
1821 else if (c
&& c
->ext
.actual
!= NULL
)
1823 arg0
= c
->ext
.actual
;
1825 if (c
->resolved_sym
)
1826 esym
= c
->resolved_sym
;
1828 esym
= c
->symtree
->n
.sym
;
1831 if (!esym
->attr
.elemental
)
1837 /* The rank of an elemental is the rank of its array argument(s). */
1838 for (arg
= arg0
; arg
; arg
= arg
->next
)
1840 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1842 rank
= arg
->expr
->rank
;
1843 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1844 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1845 set_by_optional
= true;
1847 /* Function specific; set the result rank and shape. */
1851 if (!expr
->shape
&& arg
->expr
->shape
)
1853 expr
->shape
= gfc_get_shape (rank
);
1854 for (i
= 0; i
< rank
; i
++)
1855 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1862 /* If it is an array, it shall not be supplied as an actual argument
1863 to an elemental procedure unless an array of the same rank is supplied
1864 as an actual argument corresponding to a nonoptional dummy argument of
1865 that elemental procedure(12.4.1.5). */
1866 formal_optional
= false;
1868 iformal
= isym
->formal
;
1870 eformal
= esym
->formal
;
1872 for (arg
= arg0
; arg
; arg
= arg
->next
)
1876 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1877 formal_optional
= true;
1878 eformal
= eformal
->next
;
1880 else if (isym
&& iformal
)
1882 if (iformal
->optional
)
1883 formal_optional
= true;
1884 iformal
= iformal
->next
;
1887 formal_optional
= true;
1889 if (pedantic
&& arg
->expr
!= NULL
1890 && arg
->expr
->expr_type
== EXPR_VARIABLE
1891 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1894 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1895 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1897 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1898 "MISSING, it cannot be the actual argument of an "
1899 "ELEMENTAL procedure unless there is a non-optional "
1900 "argument with the same rank (12.4.1.5)",
1901 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1906 for (arg
= arg0
; arg
; arg
= arg
->next
)
1908 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1911 /* Being elemental, the last upper bound of an assumed size array
1912 argument must be present. */
1913 if (resolve_assumed_size_actual (arg
->expr
))
1916 /* Elemental procedure's array actual arguments must conform. */
1919 if (gfc_check_conformance (arg
->expr
, e
,
1920 "elemental procedure") == FAILURE
)
1927 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1928 is an array, the intent inout/out variable needs to be also an array. */
1929 if (rank
> 0 && esym
&& expr
== NULL
)
1930 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1931 arg
= arg
->next
, eformal
= eformal
->next
)
1932 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1933 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1934 && arg
->expr
&& arg
->expr
->rank
== 0)
1936 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1937 "ELEMENTAL subroutine '%s' is a scalar, but another "
1938 "actual argument is an array", &arg
->expr
->where
,
1939 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1940 : "INOUT", eformal
->sym
->name
, esym
->name
);
1947 /* This function does the checking of references to global procedures
1948 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1949 77 and 95 standards. It checks for a gsymbol for the name, making
1950 one if it does not already exist. If it already exists, then the
1951 reference being resolved must correspond to the type of gsymbol.
1952 Otherwise, the new symbol is equipped with the attributes of the
1953 reference. The corresponding code that is called in creating
1954 global entities is parse.c.
1956 In addition, for all but -std=legacy, the gsymbols are used to
1957 check the interfaces of external procedures from the same file.
1958 The namespace of the gsymbol is resolved and then, once this is
1959 done the interface is checked. */
1963 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
1965 if (!gsym_ns
->proc_name
->attr
.recursive
)
1968 if (sym
->ns
== gsym_ns
)
1971 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
1978 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
1980 if (gsym_ns
->entries
)
1982 gfc_entry_list
*entry
= gsym_ns
->entries
;
1984 for (; entry
; entry
= entry
->next
)
1986 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
1988 if (strcmp (gsym_ns
->proc_name
->name
,
1989 sym
->ns
->proc_name
->name
) == 0)
1993 && strcmp (gsym_ns
->proc_name
->name
,
1994 sym
->ns
->parent
->proc_name
->name
) == 0)
2003 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2004 gfc_actual_arglist
**actual
, int sub
)
2008 enum gfc_symbol_type type
;
2010 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2012 gsym
= gfc_get_gsymbol (sym
->name
);
2014 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2015 gfc_global_used (gsym
, where
);
2017 if (gfc_option
.flag_whole_file
2018 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2019 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2020 && gsym
->type
!= GSYM_UNKNOWN
2022 && gsym
->ns
->resolved
!= -1
2023 && gsym
->ns
->proc_name
2024 && not_in_recursive (sym
, gsym
->ns
)
2025 && not_entry_self_reference (sym
, gsym
->ns
))
2027 gfc_symbol
*def_sym
;
2029 /* Resolve the gsymbol namespace if needed. */
2030 if (!gsym
->ns
->resolved
)
2032 gfc_dt_list
*old_dt_list
;
2033 struct gfc_omp_saved_state old_omp_state
;
2035 /* Stash away derived types so that the backend_decls do not
2037 old_dt_list
= gfc_derived_types
;
2038 gfc_derived_types
= NULL
;
2039 /* And stash away openmp state. */
2040 gfc_omp_save_and_clear_state (&old_omp_state
);
2042 gfc_resolve (gsym
->ns
);
2044 /* Store the new derived types with the global namespace. */
2045 if (gfc_derived_types
)
2046 gsym
->ns
->derived_types
= gfc_derived_types
;
2048 /* Restore the derived types of this namespace. */
2049 gfc_derived_types
= old_dt_list
;
2050 /* And openmp state. */
2051 gfc_omp_restore_state (&old_omp_state
);
2054 /* Make sure that translation for the gsymbol occurs before
2055 the procedure currently being resolved. */
2056 ns
= gfc_global_ns_list
;
2057 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2059 if (ns
->sibling
== gsym
->ns
)
2061 ns
->sibling
= gsym
->ns
->sibling
;
2062 gsym
->ns
->sibling
= gfc_global_ns_list
;
2063 gfc_global_ns_list
= gsym
->ns
;
2068 def_sym
= gsym
->ns
->proc_name
;
2069 if (def_sym
->attr
.entry_master
)
2071 gfc_entry_list
*entry
;
2072 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2073 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2075 def_sym
= entry
->sym
;
2080 /* Differences in constant character lengths. */
2081 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2083 long int l1
= 0, l2
= 0;
2084 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2085 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2088 && cl1
->length
!= NULL
2089 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2090 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2093 && cl2
->length
!= NULL
2094 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2095 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2097 if (l1
&& l2
&& l1
!= l2
)
2098 gfc_error ("Character length mismatch in return type of "
2099 "function '%s' at %L (%ld/%ld)", sym
->name
,
2100 &sym
->declared_at
, l1
, l2
);
2103 /* Type mismatch of function return type and expected type. */
2104 if (sym
->attr
.function
2105 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2106 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2107 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2108 gfc_typename (&def_sym
->ts
));
2110 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2112 gfc_formal_arglist
*arg
= def_sym
->formal
;
2113 for ( ; arg
; arg
= arg
->next
)
2116 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2117 else if (arg
->sym
->attr
.allocatable
2118 || arg
->sym
->attr
.asynchronous
2119 || arg
->sym
->attr
.optional
2120 || arg
->sym
->attr
.pointer
2121 || arg
->sym
->attr
.target
2122 || arg
->sym
->attr
.value
2123 || arg
->sym
->attr
.volatile_
)
2125 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2126 "has an attribute that requires an explicit "
2127 "interface for this procedure", arg
->sym
->name
,
2128 sym
->name
, &sym
->declared_at
);
2131 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2132 else if (arg
->sym
&& arg
->sym
->as
2133 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2135 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2136 "argument '%s' must have an explicit interface",
2137 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2140 /* F2008, 12.4.2.2 (2c) */
2141 else if (arg
->sym
->attr
.codimension
)
2143 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2144 "'%s' must have an explicit interface",
2145 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2148 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2149 else if (false) /* TODO: is a parametrized derived type */
2151 gfc_error ("Procedure '%s' at %L with parametrized derived "
2152 "type argument '%s' must have an explicit "
2153 "interface", sym
->name
, &sym
->declared_at
,
2157 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2158 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2160 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2161 "argument '%s' must have an explicit interface",
2162 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2167 if (def_sym
->attr
.function
)
2169 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2170 if (def_sym
->as
&& def_sym
->as
->rank
2171 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2172 gfc_error ("The reference to function '%s' at %L either needs an "
2173 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2176 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2177 if ((def_sym
->result
->attr
.pointer
2178 || def_sym
->result
->attr
.allocatable
)
2179 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2180 || def_sym
->result
->attr
.pointer
2181 != sym
->result
->attr
.pointer
2182 || def_sym
->result
->attr
.allocatable
2183 != sym
->result
->attr
.allocatable
))
2184 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2185 "result must have an explicit interface", sym
->name
,
2188 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2189 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2190 && def_sym
->ts
.u
.cl
->length
!= NULL
)
2192 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2194 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2195 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2197 gfc_error ("Nonconstant character-length function '%s' at %L "
2198 "must have an explicit interface", sym
->name
,
2204 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2205 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2207 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2208 "interface", sym
->name
, &sym
->declared_at
);
2211 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2212 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2214 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2215 "an explicit interface", sym
->name
, &sym
->declared_at
);
2218 if (gfc_option
.flag_whole_file
== 1
2219 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2220 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2221 gfc_errors_to_warnings (1);
2223 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2224 gfc_procedure_use (def_sym
, actual
, where
);
2226 gfc_errors_to_warnings (0);
2229 if (gsym
->type
== GSYM_UNKNOWN
)
2232 gsym
->where
= *where
;
2239 /************* Function resolution *************/
2241 /* Resolve a function call known to be generic.
2242 Section 14.1.2.4.1. */
2245 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2249 if (sym
->attr
.generic
)
2251 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2254 expr
->value
.function
.name
= s
->name
;
2255 expr
->value
.function
.esym
= s
;
2257 if (s
->ts
.type
!= BT_UNKNOWN
)
2259 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2260 expr
->ts
= s
->result
->ts
;
2263 expr
->rank
= s
->as
->rank
;
2264 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2265 expr
->rank
= s
->result
->as
->rank
;
2267 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2272 /* TODO: Need to search for elemental references in generic
2276 if (sym
->attr
.intrinsic
)
2277 return gfc_intrinsic_func_interface (expr
, 0);
2284 resolve_generic_f (gfc_expr
*expr
)
2289 sym
= expr
->symtree
->n
.sym
;
2293 m
= resolve_generic_f0 (expr
, sym
);
2296 else if (m
== MATCH_ERROR
)
2300 if (sym
->ns
->parent
== NULL
)
2302 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2306 if (!generic_sym (sym
))
2310 /* Last ditch attempt. See if the reference is to an intrinsic
2311 that possesses a matching interface. 14.1.2.4 */
2312 if (sym
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2314 gfc_error ("There is no specific function for the generic '%s' at %L",
2315 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2319 m
= gfc_intrinsic_func_interface (expr
, 0);
2323 gfc_error ("Generic function '%s' at %L is not consistent with a "
2324 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2331 /* Resolve a function call known to be specific. */
2334 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2338 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2340 if (sym
->attr
.dummy
)
2342 sym
->attr
.proc
= PROC_DUMMY
;
2346 sym
->attr
.proc
= PROC_EXTERNAL
;
2350 if (sym
->attr
.proc
== PROC_MODULE
2351 || sym
->attr
.proc
== PROC_ST_FUNCTION
2352 || sym
->attr
.proc
== PROC_INTERNAL
)
2355 if (sym
->attr
.intrinsic
)
2357 m
= gfc_intrinsic_func_interface (expr
, 1);
2361 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2362 "with an intrinsic", sym
->name
, &expr
->where
);
2370 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2373 expr
->ts
= sym
->result
->ts
;
2376 expr
->value
.function
.name
= sym
->name
;
2377 expr
->value
.function
.esym
= sym
;
2378 if (sym
->as
!= NULL
)
2379 expr
->rank
= sym
->as
->rank
;
2386 resolve_specific_f (gfc_expr
*expr
)
2391 sym
= expr
->symtree
->n
.sym
;
2395 m
= resolve_specific_f0 (sym
, expr
);
2398 if (m
== MATCH_ERROR
)
2401 if (sym
->ns
->parent
== NULL
)
2404 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2410 gfc_error ("Unable to resolve the specific function '%s' at %L",
2411 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2417 /* Resolve a procedure call not known to be generic nor specific. */
2420 resolve_unknown_f (gfc_expr
*expr
)
2425 sym
= expr
->symtree
->n
.sym
;
2427 if (sym
->attr
.dummy
)
2429 sym
->attr
.proc
= PROC_DUMMY
;
2430 expr
->value
.function
.name
= sym
->name
;
2434 /* See if we have an intrinsic function reference. */
2436 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2438 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2443 /* The reference is to an external name. */
2445 sym
->attr
.proc
= PROC_EXTERNAL
;
2446 expr
->value
.function
.name
= sym
->name
;
2447 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2449 if (sym
->as
!= NULL
)
2450 expr
->rank
= sym
->as
->rank
;
2452 /* Type of the expression is either the type of the symbol or the
2453 default type of the symbol. */
2456 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2458 if (sym
->ts
.type
!= BT_UNKNOWN
)
2462 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2464 if (ts
->type
== BT_UNKNOWN
)
2466 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2467 sym
->name
, &expr
->where
);
2478 /* Return true, if the symbol is an external procedure. */
2480 is_external_proc (gfc_symbol
*sym
)
2482 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2483 && !(sym
->attr
.intrinsic
2484 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
2485 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2486 && !sym
->attr
.proc_pointer
2487 && !sym
->attr
.use_assoc
2495 /* Figure out if a function reference is pure or not. Also set the name
2496 of the function for a potential error message. Return nonzero if the
2497 function is PURE, zero if not. */
2499 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2502 pure_function (gfc_expr
*e
, const char **name
)
2508 if (e
->symtree
!= NULL
2509 && e
->symtree
->n
.sym
!= NULL
2510 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2511 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2513 if (e
->value
.function
.esym
)
2515 pure
= gfc_pure (e
->value
.function
.esym
);
2516 *name
= e
->value
.function
.esym
->name
;
2518 else if (e
->value
.function
.isym
)
2520 pure
= e
->value
.function
.isym
->pure
2521 || e
->value
.function
.isym
->elemental
;
2522 *name
= e
->value
.function
.isym
->name
;
2526 /* Implicit functions are not pure. */
2528 *name
= e
->value
.function
.name
;
2536 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2537 int *f ATTRIBUTE_UNUSED
)
2541 /* Don't bother recursing into other statement functions
2542 since they will be checked individually for purity. */
2543 if (e
->expr_type
!= EXPR_FUNCTION
2545 || e
->symtree
->n
.sym
== sym
2546 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2549 return pure_function (e
, &name
) ? false : true;
2554 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2556 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2561 is_scalar_expr_ptr (gfc_expr
*expr
)
2563 gfc_try retval
= SUCCESS
;
2568 /* See if we have a gfc_ref, which means we have a substring, array
2569 reference, or a component. */
2570 if (expr
->ref
!= NULL
)
2573 while (ref
->next
!= NULL
)
2579 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2580 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2585 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2587 else if (ref
->u
.ar
.type
== AR_FULL
)
2589 /* The user can give a full array if the array is of size 1. */
2590 if (ref
->u
.ar
.as
!= NULL
2591 && ref
->u
.ar
.as
->rank
== 1
2592 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2593 && ref
->u
.ar
.as
->lower
[0] != NULL
2594 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2595 && ref
->u
.ar
.as
->upper
[0] != NULL
2596 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2598 /* If we have a character string, we need to check if
2599 its length is one. */
2600 if (expr
->ts
.type
== BT_CHARACTER
)
2602 if (expr
->ts
.u
.cl
== NULL
2603 || expr
->ts
.u
.cl
->length
== NULL
2604 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2610 /* We have constant lower and upper bounds. If the
2611 difference between is 1, it can be considered a
2613 FIXME: Use gfc_dep_compare_expr instead. */
2614 start
= (int) mpz_get_si
2615 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2616 end
= (int) mpz_get_si
2617 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2618 if (end
- start
+ 1 != 1)
2633 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2635 /* Character string. Make sure it's of length 1. */
2636 if (expr
->ts
.u
.cl
== NULL
2637 || expr
->ts
.u
.cl
->length
== NULL
2638 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2641 else if (expr
->rank
!= 0)
2648 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2649 and, in the case of c_associated, set the binding label based on
2653 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2654 gfc_symbol
**new_sym
)
2656 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2657 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2658 int optional_arg
= 0;
2659 gfc_try retval
= SUCCESS
;
2660 gfc_symbol
*args_sym
;
2661 gfc_typespec
*arg_ts
;
2662 symbol_attribute arg_attr
;
2664 if (args
->expr
->expr_type
== EXPR_CONSTANT
2665 || args
->expr
->expr_type
== EXPR_OP
2666 || args
->expr
->expr_type
== EXPR_NULL
)
2668 gfc_error ("Argument to '%s' at %L is not a variable",
2669 sym
->name
, &(args
->expr
->where
));
2673 args_sym
= args
->expr
->symtree
->n
.sym
;
2675 /* The typespec for the actual arg should be that stored in the expr
2676 and not necessarily that of the expr symbol (args_sym), because
2677 the actual expression could be a part-ref of the expr symbol. */
2678 arg_ts
= &(args
->expr
->ts
);
2679 arg_attr
= gfc_expr_attr (args
->expr
);
2681 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2683 /* If the user gave two args then they are providing something for
2684 the optional arg (the second cptr). Therefore, set the name and
2685 binding label to the c_associated for two cptrs. Otherwise,
2686 set c_associated to expect one cptr. */
2690 sprintf (name
, "%s_2", sym
->name
);
2691 sprintf (binding_label
, "%s_2", sym
->binding_label
);
2697 sprintf (name
, "%s_1", sym
->name
);
2698 sprintf (binding_label
, "%s_1", sym
->binding_label
);
2702 /* Get a new symbol for the version of c_associated that
2704 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
2706 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2707 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2709 sprintf (name
, "%s", sym
->name
);
2710 sprintf (binding_label
, "%s", sym
->binding_label
);
2712 /* Error check the call. */
2713 if (args
->next
!= NULL
)
2715 gfc_error_now ("More actual than formal arguments in '%s' "
2716 "call at %L", name
, &(args
->expr
->where
));
2719 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2724 /* Make sure we have either the target or pointer attribute. */
2725 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2727 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2728 "a TARGET or an associated pointer",
2730 sym
->name
, &(args
->expr
->where
));
2734 if (gfc_is_coindexed (args
->expr
))
2736 gfc_error_now ("Coindexed argument not permitted"
2737 " in '%s' call at %L", name
,
2738 &(args
->expr
->where
));
2742 /* Follow references to make sure there are no array
2744 seen_section
= false;
2746 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2748 if (ref
->type
== REF_ARRAY
)
2750 if (ref
->u
.ar
.type
== AR_SECTION
)
2751 seen_section
= true;
2753 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2756 for (r
= ref
->next
; r
; r
=r
->next
)
2757 if (r
->type
== REF_COMPONENT
)
2759 gfc_error_now ("Array section not permitted"
2760 " in '%s' call at %L", name
,
2761 &(args
->expr
->where
));
2769 if (seen_section
&& retval
== SUCCESS
)
2770 gfc_warning ("Array section in '%s' call at %L", name
,
2771 &(args
->expr
->where
));
2773 /* See if we have interoperable type and type param. */
2774 if (verify_c_interop (arg_ts
) == SUCCESS
2775 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2777 if (args_sym
->attr
.target
== 1)
2779 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2780 has the target attribute and is interoperable. */
2781 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2782 allocatable variable that has the TARGET attribute and
2783 is not an array of zero size. */
2784 if (args_sym
->attr
.allocatable
== 1)
2786 if (args_sym
->attr
.dimension
!= 0
2787 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2789 gfc_error_now ("Allocatable variable '%s' used as a "
2790 "parameter to '%s' at %L must not be "
2791 "an array of zero size",
2792 args_sym
->name
, sym
->name
,
2793 &(args
->expr
->where
));
2799 /* A non-allocatable target variable with C
2800 interoperable type and type parameters must be
2802 if (args_sym
&& args_sym
->attr
.dimension
)
2804 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2806 gfc_error ("Assumed-shape array '%s' at %L "
2807 "cannot be an argument to the "
2808 "procedure '%s' because "
2809 "it is not C interoperable",
2811 &(args
->expr
->where
), sym
->name
);
2814 else if (args_sym
->as
->type
== AS_DEFERRED
)
2816 gfc_error ("Deferred-shape array '%s' at %L "
2817 "cannot be an argument to the "
2818 "procedure '%s' because "
2819 "it is not C interoperable",
2821 &(args
->expr
->where
), sym
->name
);
2826 /* Make sure it's not a character string. Arrays of
2827 any type should be ok if the variable is of a C
2828 interoperable type. */
2829 if (arg_ts
->type
== BT_CHARACTER
)
2830 if (arg_ts
->u
.cl
!= NULL
2831 && (arg_ts
->u
.cl
->length
== NULL
2832 || arg_ts
->u
.cl
->length
->expr_type
2835 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2837 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2839 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2840 "at %L must have a length of 1",
2841 args_sym
->name
, sym
->name
,
2842 &(args
->expr
->where
));
2847 else if (arg_attr
.pointer
2848 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2850 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2852 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2853 "associated scalar POINTER", args_sym
->name
,
2854 sym
->name
, &(args
->expr
->where
));
2860 /* The parameter is not required to be C interoperable. If it
2861 is not C interoperable, it must be a nonpolymorphic scalar
2862 with no length type parameters. It still must have either
2863 the pointer or target attribute, and it can be
2864 allocatable (but must be allocated when c_loc is called). */
2865 if (args
->expr
->rank
!= 0
2866 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2868 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2869 "scalar", args_sym
->name
, sym
->name
,
2870 &(args
->expr
->where
));
2873 else if (arg_ts
->type
== BT_CHARACTER
2874 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2876 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2877 "%L must have a length of 1",
2878 args_sym
->name
, sym
->name
,
2879 &(args
->expr
->where
));
2882 else if (arg_ts
->type
== BT_CLASS
)
2884 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
2885 "polymorphic", args_sym
->name
, sym
->name
,
2886 &(args
->expr
->where
));
2891 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2893 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2895 /* TODO: Update this error message to allow for procedure
2896 pointers once they are implemented. */
2897 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2899 args_sym
->name
, sym
->name
,
2900 &(args
->expr
->where
));
2903 else if (args_sym
->attr
.is_bind_c
!= 1)
2905 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2907 args_sym
->name
, sym
->name
,
2908 &(args
->expr
->where
));
2913 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2918 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2919 "iso_c_binding function: '%s'!\n", sym
->name
);
2926 /* Resolve a function call, which means resolving the arguments, then figuring
2927 out which entity the name refers to. */
2930 resolve_function (gfc_expr
*expr
)
2932 gfc_actual_arglist
*arg
;
2937 procedure_type p
= PROC_INTRINSIC
;
2938 bool no_formal_args
;
2942 sym
= expr
->symtree
->n
.sym
;
2944 /* If this is a procedure pointer component, it has already been resolved. */
2945 if (gfc_is_proc_ptr_comp (expr
, NULL
))
2948 if (sym
&& sym
->attr
.intrinsic
2949 && resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
2952 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2954 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2958 /* If this ia a deferred TBP with an abstract interface (which may
2959 of course be referenced), expr->value.function.esym will be set. */
2960 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
2962 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2963 sym
->name
, &expr
->where
);
2967 /* Switch off assumed size checking and do this again for certain kinds
2968 of procedure, once the procedure itself is resolved. */
2969 need_full_assumed_size
++;
2971 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2972 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2974 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
2975 inquiry_argument
= true;
2976 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
2978 if (resolve_actual_arglist (expr
->value
.function
.actual
,
2979 p
, no_formal_args
) == FAILURE
)
2981 inquiry_argument
= false;
2985 inquiry_argument
= false;
2987 /* Need to setup the call to the correct c_associated, depending on
2988 the number of cptrs to user gives to compare. */
2989 if (sym
&& sym
->attr
.is_iso_c
== 1)
2991 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2995 /* Get the symtree for the new symbol (resolved func).
2996 the old one will be freed later, when it's no longer used. */
2997 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3000 /* Resume assumed_size checking. */
3001 need_full_assumed_size
--;
3003 /* If the procedure is external, check for usage. */
3004 if (sym
&& is_external_proc (sym
))
3005 resolve_global_procedure (sym
, &expr
->where
,
3006 &expr
->value
.function
.actual
, 0);
3008 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3010 && sym
->ts
.u
.cl
->length
== NULL
3012 && !sym
->ts
.deferred
3013 && expr
->value
.function
.esym
== NULL
3014 && !sym
->attr
.contained
)
3016 /* Internal procedures are taken care of in resolve_contained_fntype. */
3017 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3018 "be used at %L since it is not a dummy argument",
3019 sym
->name
, &expr
->where
);
3023 /* See if function is already resolved. */
3025 if (expr
->value
.function
.name
!= NULL
)
3027 if (expr
->ts
.type
== BT_UNKNOWN
)
3033 /* Apply the rules of section 14.1.2. */
3035 switch (procedure_kind (sym
))
3038 t
= resolve_generic_f (expr
);
3041 case PTYPE_SPECIFIC
:
3042 t
= resolve_specific_f (expr
);
3046 t
= resolve_unknown_f (expr
);
3050 gfc_internal_error ("resolve_function(): bad function type");
3054 /* If the expression is still a function (it might have simplified),
3055 then we check to see if we are calling an elemental function. */
3057 if (expr
->expr_type
!= EXPR_FUNCTION
)
3060 temp
= need_full_assumed_size
;
3061 need_full_assumed_size
= 0;
3063 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3066 if (omp_workshare_flag
3067 && expr
->value
.function
.esym
3068 && ! gfc_elemental (expr
->value
.function
.esym
))
3070 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3071 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3076 #define GENERIC_ID expr->value.function.isym->id
3077 else if (expr
->value
.function
.actual
!= NULL
3078 && expr
->value
.function
.isym
!= NULL
3079 && GENERIC_ID
!= GFC_ISYM_LBOUND
3080 && GENERIC_ID
!= GFC_ISYM_LEN
3081 && GENERIC_ID
!= GFC_ISYM_LOC
3082 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3084 /* Array intrinsics must also have the last upper bound of an
3085 assumed size array argument. UBOUND and SIZE have to be
3086 excluded from the check if the second argument is anything
3089 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3091 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3092 && arg
->next
!= NULL
&& arg
->next
->expr
)
3094 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3097 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3100 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3105 if (arg
->expr
!= NULL
3106 && arg
->expr
->rank
> 0
3107 && resolve_assumed_size_actual (arg
->expr
))
3113 need_full_assumed_size
= temp
;
3116 if (!pure_function (expr
, &name
) && name
)
3120 gfc_error ("reference to non-PURE function '%s' at %L inside a "
3121 "FORALL %s", name
, &expr
->where
,
3122 forall_flag
== 2 ? "mask" : "block");
3125 else if (gfc_pure (NULL
))
3127 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3128 "procedure within a PURE procedure", name
, &expr
->where
);
3133 if (!pure_function (expr
, &name
) && name
&& gfc_implicit_pure (NULL
))
3134 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3136 /* Functions without the RECURSIVE attribution are not allowed to
3137 * call themselves. */
3138 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3141 esym
= expr
->value
.function
.esym
;
3143 if (is_illegal_recursion (esym
, gfc_current_ns
))
3145 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3146 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3147 " function '%s' is not RECURSIVE",
3148 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3150 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3151 " is not RECURSIVE", esym
->name
, &expr
->where
);
3157 /* Character lengths of use associated functions may contains references to
3158 symbols not referenced from the current program unit otherwise. Make sure
3159 those symbols are marked as referenced. */
3161 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3162 && expr
->value
.function
.esym
->attr
.use_assoc
)
3164 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3167 /* Make sure that the expression has a typespec that works. */
3168 if (expr
->ts
.type
== BT_UNKNOWN
)
3170 if (expr
->symtree
->n
.sym
->result
3171 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3172 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3173 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3180 /************* Subroutine resolution *************/
3183 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3189 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3190 sym
->name
, &c
->loc
);
3191 else if (gfc_pure (NULL
))
3192 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3198 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3202 if (sym
->attr
.generic
)
3204 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3207 c
->resolved_sym
= s
;
3208 pure_subroutine (c
, s
);
3212 /* TODO: Need to search for elemental references in generic interface. */
3215 if (sym
->attr
.intrinsic
)
3216 return gfc_intrinsic_sub_interface (c
, 0);
3223 resolve_generic_s (gfc_code
*c
)
3228 sym
= c
->symtree
->n
.sym
;
3232 m
= resolve_generic_s0 (c
, sym
);
3235 else if (m
== MATCH_ERROR
)
3239 if (sym
->ns
->parent
== NULL
)
3241 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3245 if (!generic_sym (sym
))
3249 /* Last ditch attempt. See if the reference is to an intrinsic
3250 that possesses a matching interface. 14.1.2.4 */
3251 sym
= c
->symtree
->n
.sym
;
3253 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3255 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3256 sym
->name
, &c
->loc
);
3260 m
= gfc_intrinsic_sub_interface (c
, 0);
3264 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3265 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3271 /* Set the name and binding label of the subroutine symbol in the call
3272 expression represented by 'c' to include the type and kind of the
3273 second parameter. This function is for resolving the appropriate
3274 version of c_f_pointer() and c_f_procpointer(). For example, a
3275 call to c_f_pointer() for a default integer pointer could have a
3276 name of c_f_pointer_i4. If no second arg exists, which is an error
3277 for these two functions, it defaults to the generic symbol's name
3278 and binding label. */
3281 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3282 char *name
, char *binding_label
)
3284 gfc_expr
*arg
= NULL
;
3288 /* The second arg of c_f_pointer and c_f_procpointer determines
3289 the type and kind for the procedure name. */
3290 arg
= c
->ext
.actual
->next
->expr
;
3294 /* Set up the name to have the given symbol's name,
3295 plus the type and kind. */
3296 /* a derived type is marked with the type letter 'u' */
3297 if (arg
->ts
.type
== BT_DERIVED
)
3300 kind
= 0; /* set the kind as 0 for now */
3304 type
= gfc_type_letter (arg
->ts
.type
);
3305 kind
= arg
->ts
.kind
;
3308 if (arg
->ts
.type
== BT_CHARACTER
)
3309 /* Kind info for character strings not needed. */
3312 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3313 /* Set up the binding label as the given symbol's label plus
3314 the type and kind. */
3315 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
3319 /* If the second arg is missing, set the name and label as
3320 was, cause it should at least be found, and the missing
3321 arg error will be caught by compare_parameters(). */
3322 sprintf (name
, "%s", sym
->name
);
3323 sprintf (binding_label
, "%s", sym
->binding_label
);
3330 /* Resolve a generic version of the iso_c_binding procedure given
3331 (sym) to the specific one based on the type and kind of the
3332 argument(s). Currently, this function resolves c_f_pointer() and
3333 c_f_procpointer based on the type and kind of the second argument
3334 (FPTR). Other iso_c_binding procedures aren't specially handled.
3335 Upon successfully exiting, c->resolved_sym will hold the resolved
3336 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3340 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3342 gfc_symbol
*new_sym
;
3343 /* this is fine, since we know the names won't use the max */
3344 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3345 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
3346 /* default to success; will override if find error */
3347 match m
= MATCH_YES
;
3349 /* Make sure the actual arguments are in the necessary order (based on the
3350 formal args) before resolving. */
3351 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
3353 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3354 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3356 set_name_and_label (c
, sym
, name
, binding_label
);
3358 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3360 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3362 /* Make sure we got a third arg if the second arg has non-zero
3363 rank. We must also check that the type and rank are
3364 correct since we short-circuit this check in
3365 gfc_procedure_use() (called above to sort actual args). */
3366 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3368 if(c
->ext
.actual
->next
->next
== NULL
3369 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3372 gfc_error ("Missing SHAPE parameter for call to %s "
3373 "at %L", sym
->name
, &(c
->loc
));
3375 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3377 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3380 gfc_error ("SHAPE parameter for call to %s at %L must "
3381 "be a rank 1 INTEGER array", sym
->name
,
3388 if (m
!= MATCH_ERROR
)
3390 /* the 1 means to add the optional arg to formal list */
3391 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3393 /* for error reporting, say it's declared where the original was */
3394 new_sym
->declared_at
= sym
->declared_at
;
3399 /* no differences for c_loc or c_funloc */
3403 /* set the resolved symbol */
3404 if (m
!= MATCH_ERROR
)
3405 c
->resolved_sym
= new_sym
;
3407 c
->resolved_sym
= sym
;
3413 /* Resolve a subroutine call known to be specific. */
3416 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3420 if(sym
->attr
.is_iso_c
)
3422 m
= gfc_iso_c_sub_interface (c
,sym
);
3426 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3428 if (sym
->attr
.dummy
)
3430 sym
->attr
.proc
= PROC_DUMMY
;
3434 sym
->attr
.proc
= PROC_EXTERNAL
;
3438 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3441 if (sym
->attr
.intrinsic
)
3443 m
= gfc_intrinsic_sub_interface (c
, 1);
3447 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3448 "with an intrinsic", sym
->name
, &c
->loc
);
3456 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3458 c
->resolved_sym
= sym
;
3459 pure_subroutine (c
, sym
);
3466 resolve_specific_s (gfc_code
*c
)
3471 sym
= c
->symtree
->n
.sym
;
3475 m
= resolve_specific_s0 (c
, sym
);
3478 if (m
== MATCH_ERROR
)
3481 if (sym
->ns
->parent
== NULL
)
3484 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3490 sym
= c
->symtree
->n
.sym
;
3491 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3492 sym
->name
, &c
->loc
);
3498 /* Resolve a subroutine call not known to be generic nor specific. */
3501 resolve_unknown_s (gfc_code
*c
)
3505 sym
= c
->symtree
->n
.sym
;
3507 if (sym
->attr
.dummy
)
3509 sym
->attr
.proc
= PROC_DUMMY
;
3513 /* See if we have an intrinsic function reference. */
3515 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3517 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3522 /* The reference is to an external name. */
3525 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3527 c
->resolved_sym
= sym
;
3529 pure_subroutine (c
, sym
);
3535 /* Resolve a subroutine call. Although it was tempting to use the same code
3536 for functions, subroutines and functions are stored differently and this
3537 makes things awkward. */
3540 resolve_call (gfc_code
*c
)
3543 procedure_type ptype
= PROC_INTRINSIC
;
3544 gfc_symbol
*csym
, *sym
;
3545 bool no_formal_args
;
3547 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3549 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3551 gfc_error ("'%s' at %L has a type, which is not consistent with "
3552 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3556 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3559 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3560 sym
= st
? st
->n
.sym
: NULL
;
3561 if (sym
&& csym
!= sym
3562 && sym
->ns
== gfc_current_ns
3563 && sym
->attr
.flavor
== FL_PROCEDURE
3564 && sym
->attr
.contained
)
3567 if (csym
->attr
.generic
)
3568 c
->symtree
->n
.sym
= sym
;
3571 csym
= c
->symtree
->n
.sym
;
3575 /* If this ia a deferred TBP with an abstract interface
3576 (which may of course be referenced), c->expr1 will be set. */
3577 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3579 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3580 csym
->name
, &c
->loc
);
3584 /* Subroutines without the RECURSIVE attribution are not allowed to
3585 * call themselves. */
3586 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3588 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3589 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3590 " subroutine '%s' is not RECURSIVE",
3591 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3593 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3594 " is not RECURSIVE", csym
->name
, &c
->loc
);
3599 /* Switch off assumed size checking and do this again for certain kinds
3600 of procedure, once the procedure itself is resolved. */
3601 need_full_assumed_size
++;
3604 ptype
= csym
->attr
.proc
;
3606 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3607 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3608 no_formal_args
) == FAILURE
)
3611 /* Resume assumed_size checking. */
3612 need_full_assumed_size
--;
3614 /* If external, check for usage. */
3615 if (csym
&& is_external_proc (csym
))
3616 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3619 if (c
->resolved_sym
== NULL
)
3621 c
->resolved_isym
= NULL
;
3622 switch (procedure_kind (csym
))
3625 t
= resolve_generic_s (c
);
3628 case PTYPE_SPECIFIC
:
3629 t
= resolve_specific_s (c
);
3633 t
= resolve_unknown_s (c
);
3637 gfc_internal_error ("resolve_subroutine(): bad function type");
3641 /* Some checks of elemental subroutine actual arguments. */
3642 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3649 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3650 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3651 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3652 if their shapes do not match. If either op1->shape or op2->shape is
3653 NULL, return SUCCESS. */
3656 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3663 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3665 for (i
= 0; i
< op1
->rank
; i
++)
3667 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3669 gfc_error ("Shapes for operands at %L and %L are not conformable",
3670 &op1
->where
, &op2
->where
);
3681 /* Resolve an operator expression node. This can involve replacing the
3682 operation with a user defined function call. */
3685 resolve_operator (gfc_expr
*e
)
3687 gfc_expr
*op1
, *op2
;
3689 bool dual_locus_error
;
3692 /* Resolve all subnodes-- give them types. */
3694 switch (e
->value
.op
.op
)
3697 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3700 /* Fall through... */
3703 case INTRINSIC_UPLUS
:
3704 case INTRINSIC_UMINUS
:
3705 case INTRINSIC_PARENTHESES
:
3706 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3711 /* Typecheck the new node. */
3713 op1
= e
->value
.op
.op1
;
3714 op2
= e
->value
.op
.op2
;
3715 dual_locus_error
= false;
3717 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3718 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3720 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3724 switch (e
->value
.op
.op
)
3726 case INTRINSIC_UPLUS
:
3727 case INTRINSIC_UMINUS
:
3728 if (op1
->ts
.type
== BT_INTEGER
3729 || op1
->ts
.type
== BT_REAL
3730 || op1
->ts
.type
== BT_COMPLEX
)
3736 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3737 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3740 case INTRINSIC_PLUS
:
3741 case INTRINSIC_MINUS
:
3742 case INTRINSIC_TIMES
:
3743 case INTRINSIC_DIVIDE
:
3744 case INTRINSIC_POWER
:
3745 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3747 gfc_type_convert_binary (e
, 1);
3752 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3753 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3754 gfc_typename (&op2
->ts
));
3757 case INTRINSIC_CONCAT
:
3758 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3759 && op1
->ts
.kind
== op2
->ts
.kind
)
3761 e
->ts
.type
= BT_CHARACTER
;
3762 e
->ts
.kind
= op1
->ts
.kind
;
3767 _("Operands of string concatenation operator at %%L are %s/%s"),
3768 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3774 case INTRINSIC_NEQV
:
3775 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3777 e
->ts
.type
= BT_LOGICAL
;
3778 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3779 if (op1
->ts
.kind
< e
->ts
.kind
)
3780 gfc_convert_type (op1
, &e
->ts
, 2);
3781 else if (op2
->ts
.kind
< e
->ts
.kind
)
3782 gfc_convert_type (op2
, &e
->ts
, 2);
3786 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3787 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3788 gfc_typename (&op2
->ts
));
3793 if (op1
->ts
.type
== BT_LOGICAL
)
3795 e
->ts
.type
= BT_LOGICAL
;
3796 e
->ts
.kind
= op1
->ts
.kind
;
3800 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3801 gfc_typename (&op1
->ts
));
3805 case INTRINSIC_GT_OS
:
3807 case INTRINSIC_GE_OS
:
3809 case INTRINSIC_LT_OS
:
3811 case INTRINSIC_LE_OS
:
3812 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3814 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3818 /* Fall through... */
3821 case INTRINSIC_EQ_OS
:
3823 case INTRINSIC_NE_OS
:
3824 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3825 && op1
->ts
.kind
== op2
->ts
.kind
)
3827 e
->ts
.type
= BT_LOGICAL
;
3828 e
->ts
.kind
= gfc_default_logical_kind
;
3832 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3834 gfc_type_convert_binary (e
, 1);
3836 e
->ts
.type
= BT_LOGICAL
;
3837 e
->ts
.kind
= gfc_default_logical_kind
;
3841 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3843 _("Logicals at %%L must be compared with %s instead of %s"),
3844 (e
->value
.op
.op
== INTRINSIC_EQ
3845 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3846 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3849 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3850 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3851 gfc_typename (&op2
->ts
));
3855 case INTRINSIC_USER
:
3856 if (e
->value
.op
.uop
->op
== NULL
)
3857 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3858 else if (op2
== NULL
)
3859 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3860 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3863 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3864 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3865 gfc_typename (&op2
->ts
));
3866 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
3871 case INTRINSIC_PARENTHESES
:
3873 if (e
->ts
.type
== BT_CHARACTER
)
3874 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
3878 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3881 /* Deal with arrayness of an operand through an operator. */
3885 switch (e
->value
.op
.op
)
3887 case INTRINSIC_PLUS
:
3888 case INTRINSIC_MINUS
:
3889 case INTRINSIC_TIMES
:
3890 case INTRINSIC_DIVIDE
:
3891 case INTRINSIC_POWER
:
3892 case INTRINSIC_CONCAT
:
3896 case INTRINSIC_NEQV
:
3898 case INTRINSIC_EQ_OS
:
3900 case INTRINSIC_NE_OS
:
3902 case INTRINSIC_GT_OS
:
3904 case INTRINSIC_GE_OS
:
3906 case INTRINSIC_LT_OS
:
3908 case INTRINSIC_LE_OS
:
3910 if (op1
->rank
== 0 && op2
->rank
== 0)
3913 if (op1
->rank
== 0 && op2
->rank
!= 0)
3915 e
->rank
= op2
->rank
;
3917 if (e
->shape
== NULL
)
3918 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3921 if (op1
->rank
!= 0 && op2
->rank
== 0)
3923 e
->rank
= op1
->rank
;
3925 if (e
->shape
== NULL
)
3926 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3929 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3931 if (op1
->rank
== op2
->rank
)
3933 e
->rank
= op1
->rank
;
3934 if (e
->shape
== NULL
)
3936 t
= compare_shapes (op1
, op2
);
3940 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3945 /* Allow higher level expressions to work. */
3948 /* Try user-defined operators, and otherwise throw an error. */
3949 dual_locus_error
= true;
3951 _("Inconsistent ranks for operator at %%L and %%L"));
3958 case INTRINSIC_PARENTHESES
:
3960 case INTRINSIC_UPLUS
:
3961 case INTRINSIC_UMINUS
:
3962 /* Simply copy arrayness attribute */
3963 e
->rank
= op1
->rank
;
3965 if (e
->shape
== NULL
)
3966 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3974 /* Attempt to simplify the expression. */
3977 t
= gfc_simplify_expr (e
, 0);
3978 /* Some calls do not succeed in simplification and return FAILURE
3979 even though there is no error; e.g. variable references to
3980 PARAMETER arrays. */
3981 if (!gfc_is_constant_expr (e
))
3990 if (gfc_extend_expr (e
, &real_error
) == SUCCESS
)
3997 if (dual_locus_error
)
3998 gfc_error (msg
, &op1
->where
, &op2
->where
);
4000 gfc_error (msg
, &e
->where
);
4006 /************** Array resolution subroutines **************/
4009 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4012 /* Compare two integer expressions. */
4015 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4019 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4020 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4023 /* If either of the types isn't INTEGER, we must have
4024 raised an error earlier. */
4026 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4029 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4039 /* Compare an integer expression with an integer. */
4042 compare_bound_int (gfc_expr
*a
, int b
)
4046 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4049 if (a
->ts
.type
!= BT_INTEGER
)
4050 gfc_internal_error ("compare_bound_int(): Bad expression");
4052 i
= mpz_cmp_si (a
->value
.integer
, b
);
4062 /* Compare an integer expression with a mpz_t. */
4065 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4069 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4072 if (a
->ts
.type
!= BT_INTEGER
)
4073 gfc_internal_error ("compare_bound_int(): Bad expression");
4075 i
= mpz_cmp (a
->value
.integer
, b
);
4085 /* Compute the last value of a sequence given by a triplet.
4086 Return 0 if it wasn't able to compute the last value, or if the
4087 sequence if empty, and 1 otherwise. */
4090 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4091 gfc_expr
*stride
, mpz_t last
)
4095 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4096 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4097 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4100 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4101 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4104 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4106 if (compare_bound (start
, end
) == CMP_GT
)
4108 mpz_set (last
, end
->value
.integer
);
4112 if (compare_bound_int (stride
, 0) == CMP_GT
)
4114 /* Stride is positive */
4115 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4120 /* Stride is negative */
4121 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4126 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4127 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4128 mpz_sub (last
, end
->value
.integer
, rem
);
4135 /* Compare a single dimension of an array reference to the array
4139 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4143 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4145 gcc_assert (ar
->stride
[i
] == NULL
);
4146 /* This implies [*] as [*:] and [*:3] are not possible. */
4147 if (ar
->start
[i
] == NULL
)
4149 gcc_assert (ar
->end
[i
] == NULL
);
4154 /* Given start, end and stride values, calculate the minimum and
4155 maximum referenced indexes. */
4157 switch (ar
->dimen_type
[i
])
4164 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4167 gfc_warning ("Array reference at %L is out of bounds "
4168 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4169 mpz_get_si (ar
->start
[i
]->value
.integer
),
4170 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4172 gfc_warning ("Array reference at %L is out of bounds "
4173 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4174 mpz_get_si (ar
->start
[i
]->value
.integer
),
4175 mpz_get_si (as
->lower
[i
]->value
.integer
),
4179 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4182 gfc_warning ("Array reference at %L is out of bounds "
4183 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4184 mpz_get_si (ar
->start
[i
]->value
.integer
),
4185 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4187 gfc_warning ("Array reference at %L is out of bounds "
4188 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4189 mpz_get_si (ar
->start
[i
]->value
.integer
),
4190 mpz_get_si (as
->upper
[i
]->value
.integer
),
4199 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4200 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4202 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4204 /* Check for zero stride, which is not allowed. */
4205 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4207 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4211 /* if start == len || (stride > 0 && start < len)
4212 || (stride < 0 && start > len),
4213 then the array section contains at least one element. In this
4214 case, there is an out-of-bounds access if
4215 (start < lower || start > upper). */
4216 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4217 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4218 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4219 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4220 && comp_start_end
== CMP_GT
))
4222 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4224 gfc_warning ("Lower array reference at %L is out of bounds "
4225 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4226 mpz_get_si (AR_START
->value
.integer
),
4227 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4230 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4232 gfc_warning ("Lower array reference at %L is out of bounds "
4233 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4234 mpz_get_si (AR_START
->value
.integer
),
4235 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4240 /* If we can compute the highest index of the array section,
4241 then it also has to be between lower and upper. */
4242 mpz_init (last_value
);
4243 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4246 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4248 gfc_warning ("Upper array reference at %L is out of bounds "
4249 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4250 mpz_get_si (last_value
),
4251 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4252 mpz_clear (last_value
);
4255 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4257 gfc_warning ("Upper array reference at %L is out of bounds "
4258 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4259 mpz_get_si (last_value
),
4260 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4261 mpz_clear (last_value
);
4265 mpz_clear (last_value
);
4273 gfc_internal_error ("check_dimension(): Bad array reference");
4280 /* Compare an array reference with an array specification. */
4283 compare_spec_to_ref (gfc_array_ref
*ar
)
4290 /* TODO: Full array sections are only allowed as actual parameters. */
4291 if (as
->type
== AS_ASSUMED_SIZE
4292 && (/*ar->type == AR_FULL
4293 ||*/ (ar
->type
== AR_SECTION
4294 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4296 gfc_error ("Rightmost upper bound of assumed size array section "
4297 "not specified at %L", &ar
->where
);
4301 if (ar
->type
== AR_FULL
)
4304 if (as
->rank
!= ar
->dimen
)
4306 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4307 &ar
->where
, ar
->dimen
, as
->rank
);
4311 /* ar->codimen == 0 is a local array. */
4312 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4314 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4315 &ar
->where
, ar
->codimen
, as
->corank
);
4319 for (i
= 0; i
< as
->rank
; i
++)
4320 if (check_dimension (i
, ar
, as
) == FAILURE
)
4323 /* Local access has no coarray spec. */
4324 if (ar
->codimen
!= 0)
4325 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4327 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
)
4329 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4330 i
+ 1 - as
->rank
, &ar
->where
);
4333 if (check_dimension (i
, ar
, as
) == FAILURE
)
4341 /* Resolve one part of an array index. */
4344 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4345 int force_index_integer_kind
)
4352 if (gfc_resolve_expr (index
) == FAILURE
)
4355 if (check_scalar
&& index
->rank
!= 0)
4357 gfc_error ("Array index at %L must be scalar", &index
->where
);
4361 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4363 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4364 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4368 if (index
->ts
.type
== BT_REAL
)
4369 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
4370 &index
->where
) == FAILURE
)
4373 if ((index
->ts
.kind
!= gfc_index_integer_kind
4374 && force_index_integer_kind
)
4375 || index
->ts
.type
!= BT_INTEGER
)
4378 ts
.type
= BT_INTEGER
;
4379 ts
.kind
= gfc_index_integer_kind
;
4381 gfc_convert_type_warn (index
, &ts
, 2, 0);
4387 /* Resolve one part of an array index. */
4390 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4392 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4395 /* Resolve a dim argument to an intrinsic function. */
4398 gfc_resolve_dim_arg (gfc_expr
*dim
)
4403 if (gfc_resolve_expr (dim
) == FAILURE
)
4408 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4413 if (dim
->ts
.type
!= BT_INTEGER
)
4415 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4419 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4424 ts
.type
= BT_INTEGER
;
4425 ts
.kind
= gfc_index_integer_kind
;
4427 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4433 /* Given an expression that contains array references, update those array
4434 references to point to the right array specifications. While this is
4435 filled in during matching, this information is difficult to save and load
4436 in a module, so we take care of it here.
4438 The idea here is that the original array reference comes from the
4439 base symbol. We traverse the list of reference structures, setting
4440 the stored reference to references. Component references can
4441 provide an additional array specification. */
4444 find_array_spec (gfc_expr
*e
)
4448 gfc_symbol
*derived
;
4451 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4452 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4454 as
= e
->symtree
->n
.sym
->as
;
4457 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4462 gfc_internal_error ("find_array_spec(): Missing spec");
4469 if (derived
== NULL
)
4470 derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
4472 if (derived
->attr
.is_class
)
4473 derived
= derived
->components
->ts
.u
.derived
;
4475 c
= derived
->components
;
4477 for (; c
; c
= c
->next
)
4478 if (c
== ref
->u
.c
.component
)
4480 /* Track the sequence of component references. */
4481 if (c
->ts
.type
== BT_DERIVED
)
4482 derived
= c
->ts
.u
.derived
;
4487 gfc_internal_error ("find_array_spec(): Component not found");
4489 if (c
->attr
.dimension
)
4492 gfc_internal_error ("find_array_spec(): unused as(1)");
4503 gfc_internal_error ("find_array_spec(): unused as(2)");
4507 /* Resolve an array reference. */
4510 resolve_array_ref (gfc_array_ref
*ar
)
4512 int i
, check_scalar
;
4515 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4517 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4519 /* Do not force gfc_index_integer_kind for the start. We can
4520 do fine with any integer kind. This avoids temporary arrays
4521 created for indexing with a vector. */
4522 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4524 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4526 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4531 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4535 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4539 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4540 if (e
->expr_type
== EXPR_VARIABLE
4541 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4542 ar
->start
[i
] = gfc_get_parentheses (e
);
4546 gfc_error ("Array index at %L is an array of rank %d",
4547 &ar
->c_where
[i
], e
->rank
);
4551 /* Fill in the upper bound, which may be lower than the
4552 specified one for something like a(2:10:5), which is
4553 identical to a(2:7:5). Only relevant for strides not equal
4555 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4556 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4557 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0)
4561 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4563 if (ar
->end
[i
] == NULL
)
4566 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4568 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4570 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4571 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4573 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4584 if (ar
->type
== AR_FULL
&& ar
->as
->rank
== 0)
4585 ar
->type
= AR_ELEMENT
;
4587 /* If the reference type is unknown, figure out what kind it is. */
4589 if (ar
->type
== AR_UNKNOWN
)
4591 ar
->type
= AR_ELEMENT
;
4592 for (i
= 0; i
< ar
->dimen
; i
++)
4593 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4594 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4596 ar
->type
= AR_SECTION
;
4601 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4609 resolve_substring (gfc_ref
*ref
)
4611 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4613 if (ref
->u
.ss
.start
!= NULL
)
4615 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4618 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4620 gfc_error ("Substring start index at %L must be of type INTEGER",
4621 &ref
->u
.ss
.start
->where
);
4625 if (ref
->u
.ss
.start
->rank
!= 0)
4627 gfc_error ("Substring start index at %L must be scalar",
4628 &ref
->u
.ss
.start
->where
);
4632 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4633 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4634 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4636 gfc_error ("Substring start index at %L is less than one",
4637 &ref
->u
.ss
.start
->where
);
4642 if (ref
->u
.ss
.end
!= NULL
)
4644 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4647 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4649 gfc_error ("Substring end index at %L must be of type INTEGER",
4650 &ref
->u
.ss
.end
->where
);
4654 if (ref
->u
.ss
.end
->rank
!= 0)
4656 gfc_error ("Substring end index at %L must be scalar",
4657 &ref
->u
.ss
.end
->where
);
4661 if (ref
->u
.ss
.length
!= NULL
4662 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4663 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4664 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4666 gfc_error ("Substring end index at %L exceeds the string length",
4667 &ref
->u
.ss
.start
->where
);
4671 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4672 gfc_integer_kinds
[k
].huge
) == CMP_GT
4673 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4674 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4676 gfc_error ("Substring end index at %L is too large",
4677 &ref
->u
.ss
.end
->where
);
4686 /* This function supplies missing substring charlens. */
4689 gfc_resolve_substring_charlen (gfc_expr
*e
)
4692 gfc_expr
*start
, *end
;
4694 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4695 if (char_ref
->type
== REF_SUBSTRING
)
4701 gcc_assert (char_ref
->next
== NULL
);
4705 if (e
->ts
.u
.cl
->length
)
4706 gfc_free_expr (e
->ts
.u
.cl
->length
);
4707 else if (e
->expr_type
== EXPR_VARIABLE
4708 && e
->symtree
->n
.sym
->attr
.dummy
)
4712 e
->ts
.type
= BT_CHARACTER
;
4713 e
->ts
.kind
= gfc_default_character_kind
;
4716 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4718 if (char_ref
->u
.ss
.start
)
4719 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4721 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4723 if (char_ref
->u
.ss
.end
)
4724 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4725 else if (e
->expr_type
== EXPR_VARIABLE
)
4726 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4733 /* Length = (end - start +1). */
4734 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4735 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4736 gfc_get_int_expr (gfc_default_integer_kind
,
4739 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4740 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4742 /* Make sure that the length is simplified. */
4743 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4744 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4748 /* Resolve subtype references. */
4751 resolve_ref (gfc_expr
*expr
)
4753 int current_part_dimension
, n_components
, seen_part_dimension
;
4756 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4757 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4759 find_array_spec (expr
);
4763 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4767 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4775 resolve_substring (ref
);
4779 /* Check constraints on part references. */
4781 current_part_dimension
= 0;
4782 seen_part_dimension
= 0;
4785 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4790 switch (ref
->u
.ar
.type
)
4793 /* Coarray scalar. */
4794 if (ref
->u
.ar
.as
->rank
== 0)
4796 current_part_dimension
= 0;
4801 current_part_dimension
= 1;
4805 current_part_dimension
= 0;
4809 gfc_internal_error ("resolve_ref(): Bad array reference");
4815 if (current_part_dimension
|| seen_part_dimension
)
4818 if (ref
->u
.c
.component
->attr
.pointer
4819 || ref
->u
.c
.component
->attr
.proc_pointer
)
4821 gfc_error ("Component to the right of a part reference "
4822 "with nonzero rank must not have the POINTER "
4823 "attribute at %L", &expr
->where
);
4826 else if (ref
->u
.c
.component
->attr
.allocatable
)
4828 gfc_error ("Component to the right of a part reference "
4829 "with nonzero rank must not have the ALLOCATABLE "
4830 "attribute at %L", &expr
->where
);
4842 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4843 || ref
->next
== NULL
)
4844 && current_part_dimension
4845 && seen_part_dimension
)
4847 gfc_error ("Two or more part references with nonzero rank must "
4848 "not be specified at %L", &expr
->where
);
4852 if (ref
->type
== REF_COMPONENT
)
4854 if (current_part_dimension
)
4855 seen_part_dimension
= 1;
4857 /* reset to make sure */
4858 current_part_dimension
= 0;
4866 /* Given an expression, determine its shape. This is easier than it sounds.
4867 Leaves the shape array NULL if it is not possible to determine the shape. */
4870 expression_shape (gfc_expr
*e
)
4872 mpz_t array
[GFC_MAX_DIMENSIONS
];
4875 if (e
->rank
== 0 || e
->shape
!= NULL
)
4878 for (i
= 0; i
< e
->rank
; i
++)
4879 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4882 e
->shape
= gfc_get_shape (e
->rank
);
4884 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4889 for (i
--; i
>= 0; i
--)
4890 mpz_clear (array
[i
]);
4894 /* Given a variable expression node, compute the rank of the expression by
4895 examining the base symbol and any reference structures it may have. */
4898 expression_rank (gfc_expr
*e
)
4903 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4904 could lead to serious confusion... */
4905 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4909 if (e
->expr_type
== EXPR_ARRAY
)
4911 /* Constructors can have a rank different from one via RESHAPE(). */
4913 if (e
->symtree
== NULL
)
4919 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4920 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4926 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4928 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
4929 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
4930 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
4932 if (ref
->type
!= REF_ARRAY
)
4935 if (ref
->u
.ar
.type
== AR_FULL
)
4937 rank
= ref
->u
.ar
.as
->rank
;
4941 if (ref
->u
.ar
.type
== AR_SECTION
)
4943 /* Figure out the rank of the section. */
4945 gfc_internal_error ("expression_rank(): Two array specs");
4947 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4948 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4949 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4959 expression_shape (e
);
4963 /* Resolve a variable expression. */
4966 resolve_variable (gfc_expr
*e
)
4973 if (e
->symtree
== NULL
)
4975 sym
= e
->symtree
->n
.sym
;
4977 /* If this is an associate-name, it may be parsed with an array reference
4978 in error even though the target is scalar. Fail directly in this case. */
4979 if (sym
->assoc
&& !sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
4982 /* On the other hand, the parser may not have known this is an array;
4983 in this case, we have to add a FULL reference. */
4984 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
4986 e
->ref
= gfc_get_ref ();
4987 e
->ref
->type
= REF_ARRAY
;
4988 e
->ref
->u
.ar
.type
= AR_FULL
;
4989 e
->ref
->u
.ar
.dimen
= 0;
4992 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
4995 if (sym
->attr
.flavor
== FL_PROCEDURE
4996 && (!sym
->attr
.function
4997 || (sym
->attr
.function
&& sym
->result
4998 && sym
->result
->attr
.proc_pointer
4999 && !sym
->result
->attr
.function
)))
5001 e
->ts
.type
= BT_PROCEDURE
;
5002 goto resolve_procedure
;
5005 if (sym
->ts
.type
!= BT_UNKNOWN
)
5006 gfc_variable_attr (e
, &e
->ts
);
5009 /* Must be a simple variable reference. */
5010 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5015 if (check_assumed_size_reference (sym
, e
))
5018 /* Deal with forward references to entries during resolve_code, to
5019 satisfy, at least partially, 12.5.2.5. */
5020 if (gfc_current_ns
->entries
5021 && current_entry_id
== sym
->entry_id
5024 && cs_base
->current
->op
!= EXEC_ENTRY
)
5026 gfc_entry_list
*entry
;
5027 gfc_formal_arglist
*formal
;
5031 /* If the symbol is a dummy... */
5032 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5034 entry
= gfc_current_ns
->entries
;
5037 /* ...test if the symbol is a parameter of previous entries. */
5038 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5039 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5041 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5045 /* If it has not been seen as a dummy, this is an error. */
5048 if (specification_expr
)
5049 gfc_error ("Variable '%s', used in a specification expression"
5050 ", is referenced at %L before the ENTRY statement "
5051 "in which it is a parameter",
5052 sym
->name
, &cs_base
->current
->loc
);
5054 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5055 "statement in which it is a parameter",
5056 sym
->name
, &cs_base
->current
->loc
);
5061 /* Now do the same check on the specification expressions. */
5062 specification_expr
= 1;
5063 if (sym
->ts
.type
== BT_CHARACTER
5064 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5068 for (n
= 0; n
< sym
->as
->rank
; n
++)
5070 specification_expr
= 1;
5071 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5073 specification_expr
= 1;
5074 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5077 specification_expr
= 0;
5080 /* Update the symbol's entry level. */
5081 sym
->entry_id
= current_entry_id
+ 1;
5084 /* If a symbol has been host_associated mark it. This is used latter,
5085 to identify if aliasing is possible via host association. */
5086 if (sym
->attr
.flavor
== FL_VARIABLE
5087 && gfc_current_ns
->parent
5088 && (gfc_current_ns
->parent
== sym
->ns
5089 || (gfc_current_ns
->parent
->parent
5090 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5091 sym
->attr
.host_assoc
= 1;
5094 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5097 /* F2008, C617 and C1229. */
5098 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5099 && gfc_is_coindexed (e
))
5101 gfc_ref
*ref
, *ref2
= NULL
;
5103 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5105 if (ref
->type
== REF_COMPONENT
)
5107 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5111 for ( ; ref
; ref
= ref
->next
)
5112 if (ref
->type
== REF_COMPONENT
)
5115 /* Expression itself is not coindexed object. */
5116 if (ref
&& e
->ts
.type
== BT_CLASS
)
5118 gfc_error ("Polymorphic subobject of coindexed object at %L",
5123 /* Expression itself is coindexed object. */
5127 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5128 for ( ; c
; c
= c
->next
)
5129 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5131 gfc_error ("Coindexed object with polymorphic allocatable "
5132 "subcomponent at %L", &e
->where
);
5143 /* Checks to see that the correct symbol has been host associated.
5144 The only situation where this arises is that in which a twice
5145 contained function is parsed after the host association is made.
5146 Therefore, on detecting this, change the symbol in the expression
5147 and convert the array reference into an actual arglist if the old
5148 symbol is a variable. */
5150 check_host_association (gfc_expr
*e
)
5152 gfc_symbol
*sym
, *old_sym
;
5156 gfc_actual_arglist
*arg
, *tail
= NULL
;
5157 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5159 /* If the expression is the result of substitution in
5160 interface.c(gfc_extend_expr) because there is no way in
5161 which the host association can be wrong. */
5162 if (e
->symtree
== NULL
5163 || e
->symtree
->n
.sym
== NULL
5164 || e
->user_operator
)
5167 old_sym
= e
->symtree
->n
.sym
;
5169 if (gfc_current_ns
->parent
5170 && old_sym
->ns
!= gfc_current_ns
)
5172 /* Use the 'USE' name so that renamed module symbols are
5173 correctly handled. */
5174 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5176 if (sym
&& old_sym
!= sym
5177 && sym
->ts
.type
== old_sym
->ts
.type
5178 && sym
->attr
.flavor
== FL_PROCEDURE
5179 && sym
->attr
.contained
)
5181 /* Clear the shape, since it might not be valid. */
5182 if (e
->shape
!= NULL
)
5184 for (n
= 0; n
< e
->rank
; n
++)
5185 mpz_clear (e
->shape
[n
]);
5187 gfc_free (e
->shape
);
5190 /* Give the expression the right symtree! */
5191 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5192 gcc_assert (st
!= NULL
);
5194 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5195 || e
->expr_type
== EXPR_FUNCTION
)
5197 /* Original was function so point to the new symbol, since
5198 the actual argument list is already attached to the
5200 e
->value
.function
.esym
= NULL
;
5205 /* Original was variable so convert array references into
5206 an actual arglist. This does not need any checking now
5207 since gfc_resolve_function will take care of it. */
5208 e
->value
.function
.actual
= NULL
;
5209 e
->expr_type
= EXPR_FUNCTION
;
5212 /* Ambiguity will not arise if the array reference is not
5213 the last reference. */
5214 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5215 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5218 gcc_assert (ref
->type
== REF_ARRAY
);
5220 /* Grab the start expressions from the array ref and
5221 copy them into actual arguments. */
5222 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5224 arg
= gfc_get_actual_arglist ();
5225 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5226 if (e
->value
.function
.actual
== NULL
)
5227 tail
= e
->value
.function
.actual
= arg
;
5235 /* Dump the reference list and set the rank. */
5236 gfc_free_ref_list (e
->ref
);
5238 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5241 gfc_resolve_expr (e
);
5245 /* This might have changed! */
5246 return e
->expr_type
== EXPR_FUNCTION
;
5251 gfc_resolve_character_operator (gfc_expr
*e
)
5253 gfc_expr
*op1
= e
->value
.op
.op1
;
5254 gfc_expr
*op2
= e
->value
.op
.op2
;
5255 gfc_expr
*e1
= NULL
;
5256 gfc_expr
*e2
= NULL
;
5258 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5260 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5261 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5262 else if (op1
->expr_type
== EXPR_CONSTANT
)
5263 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5264 op1
->value
.character
.length
);
5266 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5267 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5268 else if (op2
->expr_type
== EXPR_CONSTANT
)
5269 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5270 op2
->value
.character
.length
);
5272 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5277 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5278 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5279 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5280 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5281 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5287 /* Ensure that an character expression has a charlen and, if possible, a
5288 length expression. */
5291 fixup_charlen (gfc_expr
*e
)
5293 /* The cases fall through so that changes in expression type and the need
5294 for multiple fixes are picked up. In all circumstances, a charlen should
5295 be available for the middle end to hang a backend_decl on. */
5296 switch (e
->expr_type
)
5299 gfc_resolve_character_operator (e
);
5302 if (e
->expr_type
== EXPR_ARRAY
)
5303 gfc_resolve_character_array_constructor (e
);
5305 case EXPR_SUBSTRING
:
5306 if (!e
->ts
.u
.cl
&& e
->ref
)
5307 gfc_resolve_substring_charlen (e
);
5311 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5318 /* Update an actual argument to include the passed-object for type-bound
5319 procedures at the right position. */
5321 static gfc_actual_arglist
*
5322 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5325 gcc_assert (argpos
> 0);
5329 gfc_actual_arglist
* result
;
5331 result
= gfc_get_actual_arglist ();
5335 result
->name
= name
;
5341 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5343 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5348 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5351 extract_compcall_passed_object (gfc_expr
* e
)
5355 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5357 if (e
->value
.compcall
.base_object
)
5358 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5361 po
= gfc_get_expr ();
5362 po
->expr_type
= EXPR_VARIABLE
;
5363 po
->symtree
= e
->symtree
;
5364 po
->ref
= gfc_copy_ref (e
->ref
);
5365 po
->where
= e
->where
;
5368 if (gfc_resolve_expr (po
) == FAILURE
)
5375 /* Update the arglist of an EXPR_COMPCALL expression to include the
5379 update_compcall_arglist (gfc_expr
* e
)
5382 gfc_typebound_proc
* tbp
;
5384 tbp
= e
->value
.compcall
.tbp
;
5389 po
= extract_compcall_passed_object (e
);
5393 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5399 gcc_assert (tbp
->pass_arg_num
> 0);
5400 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5408 /* Extract the passed object from a PPC call (a copy of it). */
5411 extract_ppc_passed_object (gfc_expr
*e
)
5416 po
= gfc_get_expr ();
5417 po
->expr_type
= EXPR_VARIABLE
;
5418 po
->symtree
= e
->symtree
;
5419 po
->ref
= gfc_copy_ref (e
->ref
);
5420 po
->where
= e
->where
;
5422 /* Remove PPC reference. */
5424 while ((*ref
)->next
)
5425 ref
= &(*ref
)->next
;
5426 gfc_free_ref_list (*ref
);
5429 if (gfc_resolve_expr (po
) == FAILURE
)
5436 /* Update the actual arglist of a procedure pointer component to include the
5440 update_ppc_arglist (gfc_expr
* e
)
5444 gfc_typebound_proc
* tb
;
5446 if (!gfc_is_proc_ptr_comp (e
, &ppc
))
5453 else if (tb
->nopass
)
5456 po
= extract_ppc_passed_object (e
);
5463 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5468 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5470 gfc_error ("Base object for procedure-pointer component call at %L is of"
5471 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5475 gcc_assert (tb
->pass_arg_num
> 0);
5476 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5484 /* Check that the object a TBP is called on is valid, i.e. it must not be
5485 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5488 check_typebound_baseobject (gfc_expr
* e
)
5491 gfc_try return_value
= FAILURE
;
5493 base
= extract_compcall_passed_object (e
);
5497 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5500 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5502 gfc_error ("Base object for type-bound procedure call at %L is of"
5503 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5507 /* F08:C1230. If the procedure called is NOPASS,
5508 the base object must be scalar. */
5509 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
> 0)
5511 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5512 " be scalar", &e
->where
);
5516 /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
5519 gfc_error ("Non-scalar base object at %L currently not implemented",
5524 return_value
= SUCCESS
;
5527 gfc_free_expr (base
);
5528 return return_value
;
5532 /* Resolve a call to a type-bound procedure, either function or subroutine,
5533 statically from the data in an EXPR_COMPCALL expression. The adapted
5534 arglist and the target-procedure symtree are returned. */
5537 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5538 gfc_actual_arglist
** actual
)
5540 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5541 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5543 /* Update the actual arglist for PASS. */
5544 if (update_compcall_arglist (e
) == FAILURE
)
5547 *actual
= e
->value
.compcall
.actual
;
5548 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5550 gfc_free_ref_list (e
->ref
);
5552 e
->value
.compcall
.actual
= NULL
;
5558 /* Get the ultimate declared type from an expression. In addition,
5559 return the last class/derived type reference and the copy of the
5562 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5565 gfc_symbol
*declared
;
5572 *new_ref
= gfc_copy_ref (e
->ref
);
5574 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5576 if (ref
->type
!= REF_COMPONENT
)
5579 if (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5580 || ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5582 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5588 if (declared
== NULL
)
5589 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5595 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5596 which of the specific bindings (if any) matches the arglist and transform
5597 the expression into a call of that binding. */
5600 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5602 gfc_typebound_proc
* genproc
;
5603 const char* genname
;
5605 gfc_symbol
*derived
;
5607 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5608 genname
= e
->value
.compcall
.name
;
5609 genproc
= e
->value
.compcall
.tbp
;
5611 if (!genproc
->is_generic
)
5614 /* Try the bindings on this type and in the inheritance hierarchy. */
5615 for (; genproc
; genproc
= genproc
->overridden
)
5619 gcc_assert (genproc
->is_generic
);
5620 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5623 gfc_actual_arglist
* args
;
5626 gcc_assert (g
->specific
);
5628 if (g
->specific
->error
)
5631 target
= g
->specific
->u
.specific
->n
.sym
;
5633 /* Get the right arglist by handling PASS/NOPASS. */
5634 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5635 if (!g
->specific
->nopass
)
5638 po
= extract_compcall_passed_object (e
);
5642 gcc_assert (g
->specific
->pass_arg_num
> 0);
5643 gcc_assert (!g
->specific
->error
);
5644 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
5645 g
->specific
->pass_arg
);
5647 resolve_actual_arglist (args
, target
->attr
.proc
,
5648 is_external_proc (target
) && !target
->formal
);
5650 /* Check if this arglist matches the formal. */
5651 matches
= gfc_arglist_matches_symbol (&args
, target
);
5653 /* Clean up and break out of the loop if we've found it. */
5654 gfc_free_actual_arglist (args
);
5657 e
->value
.compcall
.tbp
= g
->specific
;
5658 genname
= g
->specific_st
->name
;
5659 /* Pass along the name for CLASS methods, where the vtab
5660 procedure pointer component has to be referenced. */
5668 /* Nothing matching found! */
5669 gfc_error ("Found no matching specific binding for the call to the GENERIC"
5670 " '%s' at %L", genname
, &e
->where
);
5674 /* Make sure that we have the right specific instance for the name. */
5675 derived
= get_declared_from_expr (NULL
, NULL
, e
);
5677 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, false, &e
->where
);
5679 e
->value
.compcall
.tbp
= st
->n
.tb
;
5685 /* Resolve a call to a type-bound subroutine. */
5688 resolve_typebound_call (gfc_code
* c
, const char **name
)
5690 gfc_actual_arglist
* newactual
;
5691 gfc_symtree
* target
;
5693 /* Check that's really a SUBROUTINE. */
5694 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
5696 gfc_error ("'%s' at %L should be a SUBROUTINE",
5697 c
->expr1
->value
.compcall
.name
, &c
->loc
);
5701 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
5704 /* Pass along the name for CLASS methods, where the vtab
5705 procedure pointer component has to be referenced. */
5707 *name
= c
->expr1
->value
.compcall
.name
;
5709 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
5712 /* Transform into an ordinary EXEC_CALL for now. */
5714 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
5717 c
->ext
.actual
= newactual
;
5718 c
->symtree
= target
;
5719 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
5721 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
5723 gfc_free_expr (c
->expr1
);
5724 c
->expr1
= gfc_get_expr ();
5725 c
->expr1
->expr_type
= EXPR_FUNCTION
;
5726 c
->expr1
->symtree
= target
;
5727 c
->expr1
->where
= c
->loc
;
5729 return resolve_call (c
);
5733 /* Resolve a component-call expression. */
5735 resolve_compcall (gfc_expr
* e
, const char **name
)
5737 gfc_actual_arglist
* newactual
;
5738 gfc_symtree
* target
;
5740 /* Check that's really a FUNCTION. */
5741 if (!e
->value
.compcall
.tbp
->function
)
5743 gfc_error ("'%s' at %L should be a FUNCTION",
5744 e
->value
.compcall
.name
, &e
->where
);
5748 /* These must not be assign-calls! */
5749 gcc_assert (!e
->value
.compcall
.assign
);
5751 if (check_typebound_baseobject (e
) == FAILURE
)
5754 /* Pass along the name for CLASS methods, where the vtab
5755 procedure pointer component has to be referenced. */
5757 *name
= e
->value
.compcall
.name
;
5759 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
5761 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5763 /* Take the rank from the function's symbol. */
5764 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
5765 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
5767 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
5768 arglist to the TBP's binding target. */
5770 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
5773 e
->value
.function
.actual
= newactual
;
5774 e
->value
.function
.name
= NULL
;
5775 e
->value
.function
.esym
= target
->n
.sym
;
5776 e
->value
.function
.isym
= NULL
;
5777 e
->symtree
= target
;
5778 e
->ts
= target
->n
.sym
->ts
;
5779 e
->expr_type
= EXPR_FUNCTION
;
5781 /* Resolution is not necessary if this is a class subroutine; this
5782 function only has to identify the specific proc. Resolution of
5783 the call will be done next in resolve_typebound_call. */
5784 return gfc_resolve_expr (e
);
5789 /* Resolve a typebound function, or 'method'. First separate all
5790 the non-CLASS references by calling resolve_compcall directly. */
5793 resolve_typebound_function (gfc_expr
* e
)
5795 gfc_symbol
*declared
;
5806 /* Deal with typebound operators for CLASS objects. */
5807 expr
= e
->value
.compcall
.base_object
;
5808 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
5810 /* Since the typebound operators are generic, we have to ensure
5811 that any delays in resolution are corrected and that the vtab
5814 declared
= ts
.u
.derived
;
5815 c
= gfc_find_component (declared
, "_vptr", true, true);
5816 if (c
->ts
.u
.derived
== NULL
)
5817 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5819 if (resolve_compcall (e
, &name
) == FAILURE
)
5822 /* Use the generic name if it is there. */
5823 name
= name
? name
: e
->value
.function
.esym
->name
;
5824 e
->symtree
= expr
->symtree
;
5825 e
->ref
= gfc_copy_ref (expr
->ref
);
5826 gfc_add_vptr_component (e
);
5827 gfc_add_component_ref (e
, name
);
5828 e
->value
.function
.esym
= NULL
;
5833 return resolve_compcall (e
, NULL
);
5835 if (resolve_ref (e
) == FAILURE
)
5838 /* Get the CLASS declared type. */
5839 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
);
5841 /* Weed out cases of the ultimate component being a derived type. */
5842 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5843 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5845 gfc_free_ref_list (new_ref
);
5846 return resolve_compcall (e
, NULL
);
5849 c
= gfc_find_component (declared
, "_data", true, true);
5850 declared
= c
->ts
.u
.derived
;
5852 /* Treat the call as if it is a typebound procedure, in order to roll
5853 out the correct name for the specific function. */
5854 if (resolve_compcall (e
, &name
) == FAILURE
)
5858 /* Then convert the expression to a procedure pointer component call. */
5859 e
->value
.function
.esym
= NULL
;
5865 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5866 gfc_add_vptr_component (e
);
5867 gfc_add_component_ref (e
, name
);
5869 /* Recover the typespec for the expression. This is really only
5870 necessary for generic procedures, where the additional call
5871 to gfc_add_component_ref seems to throw the collection of the
5872 correct typespec. */
5877 /* Resolve a typebound subroutine, or 'method'. First separate all
5878 the non-CLASS references by calling resolve_typebound_call
5882 resolve_typebound_subroutine (gfc_code
*code
)
5884 gfc_symbol
*declared
;
5893 st
= code
->expr1
->symtree
;
5895 /* Deal with typebound operators for CLASS objects. */
5896 expr
= code
->expr1
->value
.compcall
.base_object
;
5897 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
5899 /* Since the typebound operators are generic, we have to ensure
5900 that any delays in resolution are corrected and that the vtab
5902 declared
= expr
->ts
.u
.derived
;
5903 c
= gfc_find_component (declared
, "_vptr", true, true);
5904 if (c
->ts
.u
.derived
== NULL
)
5905 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
5907 if (resolve_typebound_call (code
, &name
) == FAILURE
)
5910 /* Use the generic name if it is there. */
5911 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
5912 code
->expr1
->symtree
= expr
->symtree
;
5913 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
5914 gfc_add_vptr_component (code
->expr1
);
5915 gfc_add_component_ref (code
->expr1
, name
);
5916 code
->expr1
->value
.function
.esym
= NULL
;
5921 return resolve_typebound_call (code
, NULL
);
5923 if (resolve_ref (code
->expr1
) == FAILURE
)
5926 /* Get the CLASS declared type. */
5927 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
);
5929 /* Weed out cases of the ultimate component being a derived type. */
5930 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
5931 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
5933 gfc_free_ref_list (new_ref
);
5934 return resolve_typebound_call (code
, NULL
);
5937 if (resolve_typebound_call (code
, &name
) == FAILURE
)
5939 ts
= code
->expr1
->ts
;
5941 /* Then convert the expression to a procedure pointer component call. */
5942 code
->expr1
->value
.function
.esym
= NULL
;
5943 code
->expr1
->symtree
= st
;
5946 code
->expr1
->ref
= new_ref
;
5948 /* '_vptr' points to the vtab, which contains the procedure pointers. */
5949 gfc_add_vptr_component (code
->expr1
);
5950 gfc_add_component_ref (code
->expr1
, name
);
5952 /* Recover the typespec for the expression. This is really only
5953 necessary for generic procedures, where the additional call
5954 to gfc_add_component_ref seems to throw the collection of the
5955 correct typespec. */
5956 code
->expr1
->ts
= ts
;
5961 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
5964 resolve_ppc_call (gfc_code
* c
)
5966 gfc_component
*comp
;
5969 b
= gfc_is_proc_ptr_comp (c
->expr1
, &comp
);
5972 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
5973 c
->expr1
->expr_type
= EXPR_VARIABLE
;
5975 if (!comp
->attr
.subroutine
)
5976 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
5978 if (resolve_ref (c
->expr1
) == FAILURE
)
5981 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
5984 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
5986 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
5987 comp
->formal
== NULL
) == FAILURE
)
5990 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
5996 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
5999 resolve_expr_ppc (gfc_expr
* e
)
6001 gfc_component
*comp
;
6004 b
= gfc_is_proc_ptr_comp (e
, &comp
);
6007 /* Convert to EXPR_FUNCTION. */
6008 e
->expr_type
= EXPR_FUNCTION
;
6009 e
->value
.function
.isym
= NULL
;
6010 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6012 if (comp
->as
!= NULL
)
6013 e
->rank
= comp
->as
->rank
;
6015 if (!comp
->attr
.function
)
6016 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6018 if (resolve_ref (e
) == FAILURE
)
6021 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6022 comp
->formal
== NULL
) == FAILURE
)
6025 if (update_ppc_arglist (e
) == FAILURE
)
6028 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6035 gfc_is_expandable_expr (gfc_expr
*e
)
6037 gfc_constructor
*con
;
6039 if (e
->expr_type
== EXPR_ARRAY
)
6041 /* Traverse the constructor looking for variables that are flavor
6042 parameter. Parameters must be expanded since they are fully used at
6044 con
= gfc_constructor_first (e
->value
.constructor
);
6045 for (; con
; con
= gfc_constructor_next (con
))
6047 if (con
->expr
->expr_type
== EXPR_VARIABLE
6048 && con
->expr
->symtree
6049 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6050 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6052 if (con
->expr
->expr_type
== EXPR_ARRAY
6053 && gfc_is_expandable_expr (con
->expr
))
6061 /* Resolve an expression. That is, make sure that types of operands agree
6062 with their operators, intrinsic operators are converted to function calls
6063 for overloaded types and unresolved function references are resolved. */
6066 gfc_resolve_expr (gfc_expr
*e
)
6074 /* inquiry_argument only applies to variables. */
6075 inquiry_save
= inquiry_argument
;
6076 if (e
->expr_type
!= EXPR_VARIABLE
)
6077 inquiry_argument
= false;
6079 switch (e
->expr_type
)
6082 t
= resolve_operator (e
);
6088 if (check_host_association (e
))
6089 t
= resolve_function (e
);
6092 t
= resolve_variable (e
);
6094 expression_rank (e
);
6097 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6098 && e
->ref
->type
!= REF_SUBSTRING
)
6099 gfc_resolve_substring_charlen (e
);
6104 t
= resolve_typebound_function (e
);
6107 case EXPR_SUBSTRING
:
6108 t
= resolve_ref (e
);
6117 t
= resolve_expr_ppc (e
);
6122 if (resolve_ref (e
) == FAILURE
)
6125 t
= gfc_resolve_array_constructor (e
);
6126 /* Also try to expand a constructor. */
6129 expression_rank (e
);
6130 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6131 gfc_expand_constructor (e
, false);
6134 /* This provides the opportunity for the length of constructors with
6135 character valued function elements to propagate the string length
6136 to the expression. */
6137 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6139 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6140 here rather then add a duplicate test for it above. */
6141 gfc_expand_constructor (e
, false);
6142 t
= gfc_resolve_character_array_constructor (e
);
6147 case EXPR_STRUCTURE
:
6148 t
= resolve_ref (e
);
6152 t
= resolve_structure_cons (e
, 0);
6156 t
= gfc_simplify_expr (e
, 0);
6160 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6163 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6166 inquiry_argument
= inquiry_save
;
6172 /* Resolve an expression from an iterator. They must be scalar and have
6173 INTEGER or (optionally) REAL type. */
6176 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6177 const char *name_msgid
)
6179 if (gfc_resolve_expr (expr
) == FAILURE
)
6182 if (expr
->rank
!= 0)
6184 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6188 if (expr
->ts
.type
!= BT_INTEGER
)
6190 if (expr
->ts
.type
== BT_REAL
)
6193 return gfc_notify_std (GFC_STD_F95_DEL
,
6194 "Deleted feature: %s at %L must be integer",
6195 _(name_msgid
), &expr
->where
);
6198 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6205 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6213 /* Resolve the expressions in an iterator structure. If REAL_OK is
6214 false allow only INTEGER type iterators, otherwise allow REAL types. */
6217 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6219 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6223 if (gfc_check_vardef_context (iter
->var
, false, _("iterator variable"))
6227 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6228 "Start expression in DO loop") == FAILURE
)
6231 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6232 "End expression in DO loop") == FAILURE
)
6235 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6236 "Step expression in DO loop") == FAILURE
)
6239 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6241 if ((iter
->step
->ts
.type
== BT_INTEGER
6242 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6243 || (iter
->step
->ts
.type
== BT_REAL
6244 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6246 gfc_error ("Step expression in DO loop at %L cannot be zero",
6247 &iter
->step
->where
);
6252 /* Convert start, end, and step to the same type as var. */
6253 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6254 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6255 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6257 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6258 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6259 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6261 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6262 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6263 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6265 if (iter
->start
->expr_type
== EXPR_CONSTANT
6266 && iter
->end
->expr_type
== EXPR_CONSTANT
6267 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6270 if (iter
->start
->ts
.type
== BT_INTEGER
)
6272 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6273 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6277 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6278 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6280 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6281 gfc_warning ("DO loop at %L will be executed zero times",
6282 &iter
->step
->where
);
6289 /* Traversal function for find_forall_index. f == 2 signals that
6290 that variable itself is not to be checked - only the references. */
6293 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6295 if (expr
->expr_type
!= EXPR_VARIABLE
)
6298 /* A scalar assignment */
6299 if (!expr
->ref
|| *f
== 1)
6301 if (expr
->symtree
->n
.sym
== sym
)
6313 /* Check whether the FORALL index appears in the expression or not.
6314 Returns SUCCESS if SYM is found in EXPR. */
6317 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6319 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6326 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6327 to be a scalar INTEGER variable. The subscripts and stride are scalar
6328 INTEGERs, and if stride is a constant it must be nonzero.
6329 Furthermore "A subscript or stride in a forall-triplet-spec shall
6330 not contain a reference to any index-name in the
6331 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6334 resolve_forall_iterators (gfc_forall_iterator
*it
)
6336 gfc_forall_iterator
*iter
, *iter2
;
6338 for (iter
= it
; iter
; iter
= iter
->next
)
6340 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6341 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6342 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6345 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6346 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6347 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6348 &iter
->start
->where
);
6349 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6350 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6352 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6353 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6354 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6356 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6357 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6359 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6361 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6362 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6363 &iter
->stride
->where
, "INTEGER");
6365 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6366 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6367 gfc_error ("FORALL stride expression at %L cannot be zero",
6368 &iter
->stride
->where
);
6370 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6371 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
6374 for (iter
= it
; iter
; iter
= iter
->next
)
6375 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6377 if (find_forall_index (iter2
->start
,
6378 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6379 || find_forall_index (iter2
->end
,
6380 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6381 || find_forall_index (iter2
->stride
,
6382 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6383 gfc_error ("FORALL index '%s' may not appear in triplet "
6384 "specification at %L", iter
->var
->symtree
->name
,
6385 &iter2
->start
->where
);
6390 /* Given a pointer to a symbol that is a derived type, see if it's
6391 inaccessible, i.e. if it's defined in another module and the components are
6392 PRIVATE. The search is recursive if necessary. Returns zero if no
6393 inaccessible components are found, nonzero otherwise. */
6396 derived_inaccessible (gfc_symbol
*sym
)
6400 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6403 for (c
= sym
->components
; c
; c
= c
->next
)
6405 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6413 /* Resolve the argument of a deallocate expression. The expression must be
6414 a pointer or a full array. */
6417 resolve_deallocate_expr (gfc_expr
*e
)
6419 symbol_attribute attr
;
6420 int allocatable
, pointer
;
6425 if (gfc_resolve_expr (e
) == FAILURE
)
6428 if (e
->expr_type
!= EXPR_VARIABLE
)
6431 sym
= e
->symtree
->n
.sym
;
6433 if (sym
->ts
.type
== BT_CLASS
)
6435 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6436 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6440 allocatable
= sym
->attr
.allocatable
;
6441 pointer
= sym
->attr
.pointer
;
6443 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6448 if (ref
->u
.ar
.type
!= AR_FULL
)
6453 c
= ref
->u
.c
.component
;
6454 if (c
->ts
.type
== BT_CLASS
)
6456 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6457 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6461 allocatable
= c
->attr
.allocatable
;
6462 pointer
= c
->attr
.pointer
;
6472 attr
= gfc_expr_attr (e
);
6474 if (allocatable
== 0 && attr
.pointer
== 0)
6477 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6483 && gfc_check_vardef_context (e
, true, _("DEALLOCATE object")) == FAILURE
)
6485 if (gfc_check_vardef_context (e
, false, _("DEALLOCATE object")) == FAILURE
)
6492 /* Returns true if the expression e contains a reference to the symbol sym. */
6494 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6496 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6503 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6505 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6509 /* Given the expression node e for an allocatable/pointer of derived type to be
6510 allocated, get the expression node to be initialized afterwards (needed for
6511 derived types with default initializers, and derived types with allocatable
6512 components that need nullification.) */
6515 gfc_expr_to_initialize (gfc_expr
*e
)
6521 result
= gfc_copy_expr (e
);
6523 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6524 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6525 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6527 ref
->u
.ar
.type
= AR_FULL
;
6529 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6530 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6532 result
->rank
= ref
->u
.ar
.dimen
;
6540 /* If the last ref of an expression is an array ref, return a copy of the
6541 expression with that one removed. Otherwise, a copy of the original
6542 expression. This is used for allocate-expressions and pointer assignment
6543 LHS, where there may be an array specification that needs to be stripped
6544 off when using gfc_check_vardef_context. */
6547 remove_last_array_ref (gfc_expr
* e
)
6552 e2
= gfc_copy_expr (e
);
6553 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
6554 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
6556 gfc_free_ref_list (*r
);
6565 /* Used in resolve_allocate_expr to check that a allocation-object and
6566 a source-expr are conformable. This does not catch all possible
6567 cases; in particular a runtime checking is needed. */
6570 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
6573 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
6575 /* First compare rank. */
6576 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
6578 gfc_error ("Source-expr at %L must be scalar or have the "
6579 "same rank as the allocate-object at %L",
6580 &e1
->where
, &e2
->where
);
6591 for (i
= 0; i
< e1
->rank
; i
++)
6593 if (tail
->u
.ar
.end
[i
])
6595 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
6596 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6597 mpz_add_ui (s
, s
, 1);
6601 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
6604 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
6606 gfc_error ("Source-expr at %L and allocate-object at %L must "
6607 "have the same shape", &e1
->where
, &e2
->where
);
6620 /* Resolve the expression in an ALLOCATE statement, doing the additional
6621 checks to see whether the expression is OK or not. The expression must
6622 have a trailing array reference that gives the size of the array. */
6625 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
6627 int i
, pointer
, allocatable
, dimension
, is_abstract
;
6629 symbol_attribute attr
;
6630 gfc_ref
*ref
, *ref2
;
6633 gfc_symbol
*sym
= NULL
;
6638 /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
6639 checking of coarrays. */
6640 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6641 if (ref
->next
== NULL
)
6644 if (ref
&& ref
->type
== REF_ARRAY
)
6645 ref
->u
.ar
.in_allocate
= true;
6647 if (gfc_resolve_expr (e
) == FAILURE
)
6650 /* Make sure the expression is allocatable or a pointer. If it is
6651 pointer, the next-to-last reference must be a pointer. */
6655 sym
= e
->symtree
->n
.sym
;
6657 /* Check whether ultimate component is abstract and CLASS. */
6660 if (e
->expr_type
!= EXPR_VARIABLE
)
6663 attr
= gfc_expr_attr (e
);
6664 pointer
= attr
.pointer
;
6665 dimension
= attr
.dimension
;
6666 codimension
= attr
.codimension
;
6670 if (sym
->ts
.type
== BT_CLASS
)
6672 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6673 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6674 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
6675 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
6676 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
6680 allocatable
= sym
->attr
.allocatable
;
6681 pointer
= sym
->attr
.pointer
;
6682 dimension
= sym
->attr
.dimension
;
6683 codimension
= sym
->attr
.codimension
;
6686 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
6691 if (ref
->next
!= NULL
)
6697 if (gfc_is_coindexed (e
))
6699 gfc_error ("Coindexed allocatable object at %L",
6704 c
= ref
->u
.c
.component
;
6705 if (c
->ts
.type
== BT_CLASS
)
6707 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6708 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6709 dimension
= CLASS_DATA (c
)->attr
.dimension
;
6710 codimension
= CLASS_DATA (c
)->attr
.codimension
;
6711 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
6715 allocatable
= c
->attr
.allocatable
;
6716 pointer
= c
->attr
.pointer
;
6717 dimension
= c
->attr
.dimension
;
6718 codimension
= c
->attr
.codimension
;
6719 is_abstract
= c
->attr
.abstract
;
6731 if (allocatable
== 0 && pointer
== 0)
6733 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6738 /* Some checks for the SOURCE tag. */
6741 /* Check F03:C631. */
6742 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
6744 gfc_error ("Type of entity at %L is type incompatible with "
6745 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
6749 /* Check F03:C632 and restriction following Note 6.18. */
6750 if (code
->expr3
->rank
> 0
6751 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
6754 /* Check F03:C633. */
6755 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
6757 gfc_error ("The allocate-object at %L and the source-expr at %L "
6758 "shall have the same kind type parameter",
6759 &e
->where
, &code
->expr3
->where
);
6764 /* Check F08:C629. */
6765 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
6768 gcc_assert (e
->ts
.type
== BT_CLASS
);
6769 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
6770 "type-spec or source-expr", sym
->name
, &e
->where
);
6774 /* In the variable definition context checks, gfc_expr_attr is used
6775 on the expression. This is fooled by the array specification
6776 present in e, thus we have to eliminate that one temporarily. */
6777 e2
= remove_last_array_ref (e
);
6779 if (t
== SUCCESS
&& pointer
)
6780 t
= gfc_check_vardef_context (e2
, true, _("ALLOCATE object"));
6782 t
= gfc_check_vardef_context (e2
, false, _("ALLOCATE object"));
6789 /* Set up default initializer if needed. */
6793 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6794 ts
= code
->ext
.alloc
.ts
;
6798 if (ts
.type
== BT_CLASS
)
6799 ts
= ts
.u
.derived
->components
->ts
;
6801 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
6803 gfc_code
*init_st
= gfc_get_code ();
6804 init_st
->loc
= code
->loc
;
6805 init_st
->op
= EXEC_INIT_ASSIGN
;
6806 init_st
->expr1
= gfc_expr_to_initialize (e
);
6807 init_st
->expr2
= init_e
;
6808 init_st
->next
= code
->next
;
6809 code
->next
= init_st
;
6812 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
6814 /* Default initialization via MOLD (non-polymorphic). */
6815 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
6816 gfc_resolve_expr (rhs
);
6817 gfc_free_expr (code
->expr3
);
6821 if (e
->ts
.type
== BT_CLASS
)
6823 /* Make sure the vtab symbol is present when
6824 the module variables are generated. */
6825 gfc_typespec ts
= e
->ts
;
6827 ts
= code
->expr3
->ts
;
6828 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
6829 ts
= code
->ext
.alloc
.ts
;
6830 gfc_find_derived_vtab (ts
.u
.derived
);
6833 if (pointer
|| (dimension
== 0 && codimension
== 0))
6836 /* Make sure the last reference node is an array specifiction. */
6838 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
6839 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
6841 gfc_error ("Array specification required in ALLOCATE statement "
6842 "at %L", &e
->where
);
6846 /* Make sure that the array section reference makes sense in the
6847 context of an ALLOCATE specification. */
6851 if (codimension
&& ar
->codimen
== 0)
6853 gfc_error ("Coarray specification required in ALLOCATE statement "
6854 "at %L", &e
->where
);
6858 for (i
= 0; i
< ar
->dimen
; i
++)
6860 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
6863 switch (ar
->dimen_type
[i
])
6869 if (ar
->start
[i
] != NULL
6870 && ar
->end
[i
] != NULL
6871 && ar
->stride
[i
] == NULL
)
6874 /* Fall Through... */
6879 gfc_error ("Bad array specification in ALLOCATE statement at %L",
6885 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
6887 sym
= a
->expr
->symtree
->n
.sym
;
6889 /* TODO - check derived type components. */
6890 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
6893 if ((ar
->start
[i
] != NULL
6894 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
6895 || (ar
->end
[i
] != NULL
6896 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
6898 gfc_error ("'%s' must not appear in the array specification at "
6899 "%L in the same ALLOCATE statement where it is "
6900 "itself allocated", sym
->name
, &ar
->where
);
6906 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
6908 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
6909 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
6911 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
6913 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
6914 "statement at %L", &e
->where
);
6920 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
6921 && ar
->stride
[i
] == NULL
)
6924 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
6929 if (codimension
&& ar
->as
->rank
== 0)
6931 gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
6932 "at %L", &e
->where
);
6944 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
6946 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
6947 gfc_alloc
*a
, *p
, *q
;
6950 errmsg
= code
->expr2
;
6952 /* Check the stat variable. */
6955 gfc_check_vardef_context (stat
, false, _("STAT variable"));
6957 if ((stat
->ts
.type
!= BT_INTEGER
6958 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
6959 || stat
->ref
->type
== REF_COMPONENT
)))
6961 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
6962 "variable", &stat
->where
);
6964 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
6965 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
6967 gfc_ref
*ref1
, *ref2
;
6970 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
6971 ref1
= ref1
->next
, ref2
= ref2
->next
)
6973 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
6975 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
6984 gfc_error ("Stat-variable at %L shall not be %sd within "
6985 "the same %s statement", &stat
->where
, fcn
, fcn
);
6991 /* Check the errmsg variable. */
6995 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
6998 gfc_check_vardef_context (errmsg
, false, _("ERRMSG variable"));
7000 if ((errmsg
->ts
.type
!= BT_CHARACTER
7002 && (errmsg
->ref
->type
== REF_ARRAY
7003 || errmsg
->ref
->type
== REF_COMPONENT
)))
7004 || errmsg
->rank
> 0 )
7005 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7006 "variable", &errmsg
->where
);
7008 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7009 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7011 gfc_ref
*ref1
, *ref2
;
7014 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7015 ref1
= ref1
->next
, ref2
= ref2
->next
)
7017 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7019 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7028 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7029 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7035 /* Check that an allocate-object appears only once in the statement.
7036 FIXME: Checking derived types is disabled. */
7037 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7040 for (q
= p
->next
; q
; q
= q
->next
)
7043 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7045 /* This is a potential collision. */
7046 gfc_ref
*pr
= pe
->ref
;
7047 gfc_ref
*qr
= qe
->ref
;
7049 /* Follow the references until
7050 a) They start to differ, in which case there is no error;
7051 you can deallocate a%b and a%c in a single statement
7052 b) Both of them stop, which is an error
7053 c) One of them stops, which is also an error. */
7056 if (pr
== NULL
&& qr
== NULL
)
7058 gfc_error ("Allocate-object at %L also appears at %L",
7059 &pe
->where
, &qe
->where
);
7062 else if (pr
!= NULL
&& qr
== NULL
)
7064 gfc_error ("Allocate-object at %L is subobject of"
7065 " object at %L", &pe
->where
, &qe
->where
);
7068 else if (pr
== NULL
&& qr
!= NULL
)
7070 gfc_error ("Allocate-object at %L is subobject of"
7071 " object at %L", &qe
->where
, &pe
->where
);
7074 /* Here, pr != NULL && qr != NULL */
7075 gcc_assert(pr
->type
== qr
->type
);
7076 if (pr
->type
== REF_ARRAY
)
7078 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7080 gcc_assert (qr
->type
== REF_ARRAY
);
7082 if (pr
->next
&& qr
->next
)
7084 gfc_array_ref
*par
= &(pr
->u
.ar
);
7085 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7086 if (gfc_dep_compare_expr (par
->start
[0],
7087 qar
->start
[0]) != 0)
7093 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7104 if (strcmp (fcn
, "ALLOCATE") == 0)
7106 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7107 resolve_allocate_expr (a
->expr
, code
);
7111 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7112 resolve_deallocate_expr (a
->expr
);
7117 /************ SELECT CASE resolution subroutines ************/
7119 /* Callback function for our mergesort variant. Determines interval
7120 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7121 op1 > op2. Assumes we're not dealing with the default case.
7122 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7123 There are nine situations to check. */
7126 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7130 if (op1
->low
== NULL
) /* op1 = (:L) */
7132 /* op2 = (:N), so overlap. */
7134 /* op2 = (M:) or (M:N), L < M */
7135 if (op2
->low
!= NULL
7136 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7139 else if (op1
->high
== NULL
) /* op1 = (K:) */
7141 /* op2 = (M:), so overlap. */
7143 /* op2 = (:N) or (M:N), K > N */
7144 if (op2
->high
!= NULL
7145 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7148 else /* op1 = (K:L) */
7150 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7151 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7153 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7154 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7156 else /* op2 = (M:N) */
7160 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7163 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7172 /* Merge-sort a double linked case list, detecting overlap in the
7173 process. LIST is the head of the double linked case list before it
7174 is sorted. Returns the head of the sorted list if we don't see any
7175 overlap, or NULL otherwise. */
7178 check_case_overlap (gfc_case
*list
)
7180 gfc_case
*p
, *q
, *e
, *tail
;
7181 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7183 /* If the passed list was empty, return immediately. */
7190 /* Loop unconditionally. The only exit from this loop is a return
7191 statement, when we've finished sorting the case list. */
7198 /* Count the number of merges we do in this pass. */
7201 /* Loop while there exists a merge to be done. */
7206 /* Count this merge. */
7209 /* Cut the list in two pieces by stepping INSIZE places
7210 forward in the list, starting from P. */
7213 for (i
= 0; i
< insize
; i
++)
7222 /* Now we have two lists. Merge them! */
7223 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7225 /* See from which the next case to merge comes from. */
7228 /* P is empty so the next case must come from Q. */
7233 else if (qsize
== 0 || q
== NULL
)
7242 cmp
= compare_cases (p
, q
);
7245 /* The whole case range for P is less than the
7253 /* The whole case range for Q is greater than
7254 the case range for P. */
7261 /* The cases overlap, or they are the same
7262 element in the list. Either way, we must
7263 issue an error and get the next case from P. */
7264 /* FIXME: Sort P and Q by line number. */
7265 gfc_error ("CASE label at %L overlaps with CASE "
7266 "label at %L", &p
->where
, &q
->where
);
7274 /* Add the next element to the merged list. */
7283 /* P has now stepped INSIZE places along, and so has Q. So
7284 they're the same. */
7289 /* If we have done only one merge or none at all, we've
7290 finished sorting the cases. */
7299 /* Otherwise repeat, merging lists twice the size. */
7305 /* Check to see if an expression is suitable for use in a CASE statement.
7306 Makes sure that all case expressions are scalar constants of the same
7307 type. Return FAILURE if anything is wrong. */
7310 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7312 if (e
== NULL
) return SUCCESS
;
7314 if (e
->ts
.type
!= case_expr
->ts
.type
)
7316 gfc_error ("Expression in CASE statement at %L must be of type %s",
7317 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7321 /* C805 (R808) For a given case-construct, each case-value shall be of
7322 the same type as case-expr. For character type, length differences
7323 are allowed, but the kind type parameters shall be the same. */
7325 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7327 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7328 &e
->where
, case_expr
->ts
.kind
);
7332 /* Convert the case value kind to that of case expression kind,
7335 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7336 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7340 gfc_error ("Expression in CASE statement at %L must be scalar",
7349 /* Given a completely parsed select statement, we:
7351 - Validate all expressions and code within the SELECT.
7352 - Make sure that the selection expression is not of the wrong type.
7353 - Make sure that no case ranges overlap.
7354 - Eliminate unreachable cases and unreachable code resulting from
7355 removing case labels.
7357 The standard does allow unreachable cases, e.g. CASE (5:3). But
7358 they are a hassle for code generation, and to prevent that, we just
7359 cut them out here. This is not necessary for overlapping cases
7360 because they are illegal and we never even try to generate code.
7362 We have the additional caveat that a SELECT construct could have
7363 been a computed GOTO in the source code. Fortunately we can fairly
7364 easily work around that here: The case_expr for a "real" SELECT CASE
7365 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7366 we have to do is make sure that the case_expr is a scalar integer
7370 resolve_select (gfc_code
*code
)
7373 gfc_expr
*case_expr
;
7374 gfc_case
*cp
, *default_case
, *tail
, *head
;
7375 int seen_unreachable
;
7381 if (code
->expr1
== NULL
)
7383 /* This was actually a computed GOTO statement. */
7384 case_expr
= code
->expr2
;
7385 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7386 gfc_error ("Selection expression in computed GOTO statement "
7387 "at %L must be a scalar integer expression",
7390 /* Further checking is not necessary because this SELECT was built
7391 by the compiler, so it should always be OK. Just move the
7392 case_expr from expr2 to expr so that we can handle computed
7393 GOTOs as normal SELECTs from here on. */
7394 code
->expr1
= code
->expr2
;
7399 case_expr
= code
->expr1
;
7401 type
= case_expr
->ts
.type
;
7402 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7404 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7405 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7407 /* Punt. Going on here just produce more garbage error messages. */
7411 if (case_expr
->rank
!= 0)
7413 gfc_error ("Argument of SELECT statement at %L must be a scalar "
7414 "expression", &case_expr
->where
);
7421 /* Raise a warning if an INTEGER case value exceeds the range of
7422 the case-expr. Later, all expressions will be promoted to the
7423 largest kind of all case-labels. */
7425 if (type
== BT_INTEGER
)
7426 for (body
= code
->block
; body
; body
= body
->block
)
7427 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7430 && gfc_check_integer_range (cp
->low
->value
.integer
,
7431 case_expr
->ts
.kind
) != ARITH_OK
)
7432 gfc_warning ("Expression in CASE statement at %L is "
7433 "not in the range of %s", &cp
->low
->where
,
7434 gfc_typename (&case_expr
->ts
));
7437 && cp
->low
!= cp
->high
7438 && gfc_check_integer_range (cp
->high
->value
.integer
,
7439 case_expr
->ts
.kind
) != ARITH_OK
)
7440 gfc_warning ("Expression in CASE statement at %L is "
7441 "not in the range of %s", &cp
->high
->where
,
7442 gfc_typename (&case_expr
->ts
));
7445 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7446 of the SELECT CASE expression and its CASE values. Walk the lists
7447 of case values, and if we find a mismatch, promote case_expr to
7448 the appropriate kind. */
7450 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7452 for (body
= code
->block
; body
; body
= body
->block
)
7454 /* Walk the case label list. */
7455 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7457 /* Intercept the DEFAULT case. It does not have a kind. */
7458 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7461 /* Unreachable case ranges are discarded, so ignore. */
7462 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7463 && cp
->low
!= cp
->high
7464 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7468 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7469 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7471 if (cp
->high
!= NULL
7472 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7473 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7478 /* Assume there is no DEFAULT case. */
7479 default_case
= NULL
;
7484 for (body
= code
->block
; body
; body
= body
->block
)
7486 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7488 seen_unreachable
= 0;
7490 /* Walk the case label list, making sure that all case labels
7492 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7494 /* Count the number of cases in the whole construct. */
7497 /* Intercept the DEFAULT case. */
7498 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7500 if (default_case
!= NULL
)
7502 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7503 "by a second DEFAULT CASE at %L",
7504 &default_case
->where
, &cp
->where
);
7515 /* Deal with single value cases and case ranges. Errors are
7516 issued from the validation function. */
7517 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
7518 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
7524 if (type
== BT_LOGICAL
7525 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
7526 || cp
->low
!= cp
->high
))
7528 gfc_error ("Logical range in CASE statement at %L is not "
7529 "allowed", &cp
->low
->where
);
7534 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
7537 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
7538 if (value
& seen_logical
)
7540 gfc_error ("Constant logical value in CASE statement "
7541 "is repeated at %L",
7546 seen_logical
|= value
;
7549 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7550 && cp
->low
!= cp
->high
7551 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7553 if (gfc_option
.warn_surprising
)
7554 gfc_warning ("Range specification at %L can never "
7555 "be matched", &cp
->where
);
7557 cp
->unreachable
= 1;
7558 seen_unreachable
= 1;
7562 /* If the case range can be matched, it can also overlap with
7563 other cases. To make sure it does not, we put it in a
7564 double linked list here. We sort that with a merge sort
7565 later on to detect any overlapping cases. */
7569 head
->right
= head
->left
= NULL
;
7574 tail
->right
->left
= tail
;
7581 /* It there was a failure in the previous case label, give up
7582 for this case label list. Continue with the next block. */
7586 /* See if any case labels that are unreachable have been seen.
7587 If so, we eliminate them. This is a bit of a kludge because
7588 the case lists for a single case statement (label) is a
7589 single forward linked lists. */
7590 if (seen_unreachable
)
7592 /* Advance until the first case in the list is reachable. */
7593 while (body
->ext
.block
.case_list
!= NULL
7594 && body
->ext
.block
.case_list
->unreachable
)
7596 gfc_case
*n
= body
->ext
.block
.case_list
;
7597 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
7599 gfc_free_case_list (n
);
7602 /* Strip all other unreachable cases. */
7603 if (body
->ext
.block
.case_list
)
7605 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
7607 if (cp
->next
->unreachable
)
7609 gfc_case
*n
= cp
->next
;
7610 cp
->next
= cp
->next
->next
;
7612 gfc_free_case_list (n
);
7619 /* See if there were overlapping cases. If the check returns NULL,
7620 there was overlap. In that case we don't do anything. If head
7621 is non-NULL, we prepend the DEFAULT case. The sorted list can
7622 then used during code generation for SELECT CASE constructs with
7623 a case expression of a CHARACTER type. */
7626 head
= check_case_overlap (head
);
7628 /* Prepend the default_case if it is there. */
7629 if (head
!= NULL
&& default_case
)
7631 default_case
->left
= NULL
;
7632 default_case
->right
= head
;
7633 head
->left
= default_case
;
7637 /* Eliminate dead blocks that may be the result if we've seen
7638 unreachable case labels for a block. */
7639 for (body
= code
; body
&& body
->block
; body
= body
->block
)
7641 if (body
->block
->ext
.block
.case_list
== NULL
)
7643 /* Cut the unreachable block from the code chain. */
7644 gfc_code
*c
= body
->block
;
7645 body
->block
= c
->block
;
7647 /* Kill the dead block, but not the blocks below it. */
7649 gfc_free_statements (c
);
7653 /* More than two cases is legal but insane for logical selects.
7654 Issue a warning for it. */
7655 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
7657 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
7662 /* Check if a derived type is extensible. */
7665 gfc_type_is_extensible (gfc_symbol
*sym
)
7667 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
7671 /* Resolve an associate name: Resolve target and ensure the type-spec is
7672 correct as well as possibly the array-spec. */
7675 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
7679 gcc_assert (sym
->assoc
);
7680 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
7682 /* If this is for SELECT TYPE, the target may not yet be set. In that
7683 case, return. Resolution will be called later manually again when
7685 target
= sym
->assoc
->target
;
7688 gcc_assert (!sym
->assoc
->dangling
);
7690 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
7693 /* For variable targets, we get some attributes from the target. */
7694 if (target
->expr_type
== EXPR_VARIABLE
)
7698 gcc_assert (target
->symtree
);
7699 tsym
= target
->symtree
->n
.sym
;
7701 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
7702 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
7704 sym
->attr
.target
= (tsym
->attr
.target
|| tsym
->attr
.pointer
);
7707 /* Get type if this was not already set. Note that it can be
7708 some other type than the target in case this is a SELECT TYPE
7709 selector! So we must not update when the type is already there. */
7710 if (sym
->ts
.type
== BT_UNKNOWN
)
7711 sym
->ts
= target
->ts
;
7712 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
7714 /* See if this is a valid association-to-variable. */
7715 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
7716 && !gfc_has_vector_subscript (target
));
7718 /* Finally resolve if this is an array or not. */
7719 if (sym
->attr
.dimension
&& target
->rank
== 0)
7721 gfc_error ("Associate-name '%s' at %L is used as array",
7722 sym
->name
, &sym
->declared_at
);
7723 sym
->attr
.dimension
= 0;
7726 if (target
->rank
> 0)
7727 sym
->attr
.dimension
= 1;
7729 if (sym
->attr
.dimension
)
7731 sym
->as
= gfc_get_array_spec ();
7732 sym
->as
->rank
= target
->rank
;
7733 sym
->as
->type
= AS_DEFERRED
;
7735 /* Target must not be coindexed, thus the associate-variable
7737 sym
->as
->corank
= 0;
7742 /* Resolve a SELECT TYPE statement. */
7745 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
7747 gfc_symbol
*selector_type
;
7748 gfc_code
*body
, *new_st
, *if_st
, *tail
;
7749 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
7752 char name
[GFC_MAX_SYMBOL_LEN
];
7756 ns
= code
->ext
.block
.ns
;
7759 /* Check for F03:C813. */
7760 if (code
->expr1
->ts
.type
!= BT_CLASS
7761 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
7763 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
7764 "at %L", &code
->loc
);
7770 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
7771 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
7772 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
7775 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
7777 /* Loop over TYPE IS / CLASS IS cases. */
7778 for (body
= code
->block
; body
; body
= body
->block
)
7780 c
= body
->ext
.block
.case_list
;
7782 /* Check F03:C815. */
7783 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7784 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
7786 gfc_error ("Derived type '%s' at %L must be extensible",
7787 c
->ts
.u
.derived
->name
, &c
->where
);
7792 /* Check F03:C816. */
7793 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
7794 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
7796 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
7797 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
7802 /* Intercept the DEFAULT case. */
7803 if (c
->ts
.type
== BT_UNKNOWN
)
7805 /* Check F03:C818. */
7808 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7809 "by a second DEFAULT CASE at %L",
7810 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
7815 default_case
= body
;
7822 /* Transform SELECT TYPE statement to BLOCK and associate selector to
7823 target if present. If there are any EXIT statements referring to the
7824 SELECT TYPE construct, this is no problem because the gfc_code
7825 reference stays the same and EXIT is equally possible from the BLOCK
7826 it is changed to. */
7827 code
->op
= EXEC_BLOCK
;
7830 gfc_association_list
* assoc
;
7832 assoc
= gfc_get_association_list ();
7833 assoc
->st
= code
->expr1
->symtree
;
7834 assoc
->target
= gfc_copy_expr (code
->expr2
);
7835 /* assoc->variable will be set by resolve_assoc_var. */
7837 code
->ext
.block
.assoc
= assoc
;
7838 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
7840 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
7843 code
->ext
.block
.assoc
= NULL
;
7845 /* Add EXEC_SELECT to switch on type. */
7846 new_st
= gfc_get_code ();
7847 new_st
->op
= code
->op
;
7848 new_st
->expr1
= code
->expr1
;
7849 new_st
->expr2
= code
->expr2
;
7850 new_st
->block
= code
->block
;
7851 code
->expr1
= code
->expr2
= NULL
;
7856 ns
->code
->next
= new_st
;
7858 code
->op
= EXEC_SELECT
;
7859 gfc_add_vptr_component (code
->expr1
);
7860 gfc_add_hash_component (code
->expr1
);
7862 /* Loop over TYPE IS / CLASS IS cases. */
7863 for (body
= code
->block
; body
; body
= body
->block
)
7865 c
= body
->ext
.block
.case_list
;
7867 if (c
->ts
.type
== BT_DERIVED
)
7868 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
7869 c
->ts
.u
.derived
->hash_value
);
7871 else if (c
->ts
.type
== BT_UNKNOWN
)
7874 /* Associate temporary to selector. This should only be done
7875 when this case is actually true, so build a new ASSOCIATE
7876 that does precisely this here (instead of using the
7879 if (c
->ts
.type
== BT_CLASS
)
7880 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
7882 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
7883 st
= gfc_find_symtree (ns
->sym_root
, name
);
7884 gcc_assert (st
->n
.sym
->assoc
);
7885 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
7886 if (c
->ts
.type
== BT_DERIVED
)
7887 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
7889 new_st
= gfc_get_code ();
7890 new_st
->op
= EXEC_BLOCK
;
7891 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
7892 new_st
->ext
.block
.ns
->code
= body
->next
;
7893 body
->next
= new_st
;
7895 /* Chain in the new list only if it is marked as dangling. Otherwise
7896 there is a CASE label overlap and this is already used. Just ignore,
7897 the error is diagonsed elsewhere. */
7898 if (st
->n
.sym
->assoc
->dangling
)
7900 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
7901 st
->n
.sym
->assoc
->dangling
= 0;
7904 resolve_assoc_var (st
->n
.sym
, false);
7907 /* Take out CLASS IS cases for separate treatment. */
7909 while (body
&& body
->block
)
7911 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
7913 /* Add to class_is list. */
7914 if (class_is
== NULL
)
7916 class_is
= body
->block
;
7921 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
7922 tail
->block
= body
->block
;
7925 /* Remove from EXEC_SELECT list. */
7926 body
->block
= body
->block
->block
;
7939 /* Add a default case to hold the CLASS IS cases. */
7940 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
7941 tail
->block
= gfc_get_code ();
7943 tail
->op
= EXEC_SELECT_TYPE
;
7944 tail
->ext
.block
.case_list
= gfc_get_case ();
7945 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
7947 default_case
= tail
;
7950 /* More than one CLASS IS block? */
7951 if (class_is
->block
)
7955 /* Sort CLASS IS blocks by extension level. */
7959 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
7962 /* F03:C817 (check for doubles). */
7963 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
7964 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
7966 gfc_error ("Double CLASS IS block in SELECT TYPE "
7968 &c2
->ext
.block
.case_list
->where
);
7971 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
7972 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
7975 (*c1
)->block
= c2
->block
;
7985 /* Generate IF chain. */
7986 if_st
= gfc_get_code ();
7987 if_st
->op
= EXEC_IF
;
7989 for (body
= class_is
; body
; body
= body
->block
)
7991 new_st
->block
= gfc_get_code ();
7992 new_st
= new_st
->block
;
7993 new_st
->op
= EXEC_IF
;
7994 /* Set up IF condition: Call _gfortran_is_extension_of. */
7995 new_st
->expr1
= gfc_get_expr ();
7996 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
7997 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
7998 new_st
->expr1
->ts
.kind
= 4;
7999 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8000 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8001 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8002 /* Set up arguments. */
8003 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8004 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8005 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8006 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8007 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8008 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8009 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8010 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8011 new_st
->next
= body
->next
;
8013 if (default_case
->next
)
8015 new_st
->block
= gfc_get_code ();
8016 new_st
= new_st
->block
;
8017 new_st
->op
= EXEC_IF
;
8018 new_st
->next
= default_case
->next
;
8021 /* Replace CLASS DEFAULT code by the IF chain. */
8022 default_case
->next
= if_st
;
8025 /* Resolve the internal code. This can not be done earlier because
8026 it requires that the sym->assoc of selectors is set already. */
8027 gfc_current_ns
= ns
;
8028 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8029 gfc_current_ns
= old_ns
;
8031 resolve_select (code
);
8035 /* Resolve a transfer statement. This is making sure that:
8036 -- a derived type being transferred has only non-pointer components
8037 -- a derived type being transferred doesn't have private components, unless
8038 it's being transferred from the module where the type was defined
8039 -- we're not trying to transfer a whole assumed size array. */
8042 resolve_transfer (gfc_code
*code
)
8051 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8052 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8053 exp
= exp
->value
.op
.op1
;
8055 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8056 && exp
->expr_type
!= EXPR_FUNCTION
))
8059 /* If we are reading, the variable will be changed. Note that
8060 code->ext.dt may be NULL if the TRANSFER is related to
8061 an INQUIRE statement -- but in this case, we are not reading, either. */
8062 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8063 && gfc_check_vardef_context (exp
, false, _("item in READ")) == FAILURE
)
8066 sym
= exp
->symtree
->n
.sym
;
8069 /* Go to actual component transferred. */
8070 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8071 if (ref
->type
== REF_COMPONENT
)
8072 ts
= &ref
->u
.c
.component
->ts
;
8074 if (ts
->type
== BT_CLASS
)
8076 /* FIXME: Test for defined input/output. */
8077 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8078 "it is processed by a defined input/output procedure",
8083 if (ts
->type
== BT_DERIVED
)
8085 /* Check that transferred derived type doesn't contain POINTER
8087 if (ts
->u
.derived
->attr
.pointer_comp
)
8089 gfc_error ("Data transfer element at %L cannot have "
8090 "POINTER components", &code
->loc
);
8094 if (ts
->u
.derived
->attr
.alloc_comp
)
8096 gfc_error ("Data transfer element at %L cannot have "
8097 "ALLOCATABLE components", &code
->loc
);
8101 if (derived_inaccessible (ts
->u
.derived
))
8103 gfc_error ("Data transfer element at %L cannot have "
8104 "PRIVATE components",&code
->loc
);
8109 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
8110 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8112 gfc_error ("Data transfer element at %L cannot be a full reference to "
8113 "an assumed-size array", &code
->loc
);
8119 /*********** Toplevel code resolution subroutines ***********/
8121 /* Find the set of labels that are reachable from this block. We also
8122 record the last statement in each block. */
8125 find_reachable_labels (gfc_code
*block
)
8132 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8134 /* Collect labels in this block. We don't keep those corresponding
8135 to END {IF|SELECT}, these are checked in resolve_branch by going
8136 up through the code_stack. */
8137 for (c
= block
; c
; c
= c
->next
)
8139 if (c
->here
&& c
->op
!= EXEC_END_BLOCK
)
8140 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8143 /* Merge with labels from parent block. */
8146 gcc_assert (cs_base
->prev
->reachable_labels
);
8147 bitmap_ior_into (cs_base
->reachable_labels
,
8148 cs_base
->prev
->reachable_labels
);
8154 resolve_sync (gfc_code
*code
)
8156 /* Check imageset. The * case matches expr1 == NULL. */
8159 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8160 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8161 "INTEGER expression", &code
->expr1
->where
);
8162 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8163 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8164 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8165 &code
->expr1
->where
);
8166 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8167 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8169 gfc_constructor
*cons
;
8170 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8171 for (; cons
; cons
= gfc_constructor_next (cons
))
8172 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8173 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8174 gfc_error ("Imageset argument at %L must between 1 and "
8175 "num_images()", &cons
->expr
->where
);
8181 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8182 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8183 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8184 &code
->expr2
->where
);
8188 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8189 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8190 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8191 &code
->expr3
->where
);
8195 /* Given a branch to a label, see if the branch is conforming.
8196 The code node describes where the branch is located. */
8199 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8206 /* Step one: is this a valid branching target? */
8208 if (label
->defined
== ST_LABEL_UNKNOWN
)
8210 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8215 if (label
->defined
!= ST_LABEL_TARGET
)
8217 gfc_error ("Statement at %L is not a valid branch target statement "
8218 "for the branch statement at %L", &label
->where
, &code
->loc
);
8222 /* Step two: make sure this branch is not a branch to itself ;-) */
8224 if (code
->here
== label
)
8226 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8230 /* Step three: See if the label is in the same block as the
8231 branching statement. The hard work has been done by setting up
8232 the bitmap reachable_labels. */
8234 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8236 /* Check now whether there is a CRITICAL construct; if so, check
8237 whether the label is still visible outside of the CRITICAL block,
8238 which is invalid. */
8239 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8240 if (stack
->current
->op
== EXEC_CRITICAL
8241 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8242 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8243 " at %L", &code
->loc
, &label
->where
);
8248 /* Step four: If we haven't found the label in the bitmap, it may
8249 still be the label of the END of the enclosing block, in which
8250 case we find it by going up the code_stack. */
8252 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8254 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8256 if (stack
->current
->op
== EXEC_CRITICAL
)
8258 /* Note: A label at END CRITICAL does not leave the CRITICAL
8259 construct as END CRITICAL is still part of it. */
8260 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8261 " at %L", &code
->loc
, &label
->where
);
8268 gcc_assert (stack
->current
->next
->op
== EXEC_END_BLOCK
);
8272 /* The label is not in an enclosing block, so illegal. This was
8273 allowed in Fortran 66, so we allow it as extension. No
8274 further checks are necessary in this case. */
8275 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8276 "as the GOTO statement at %L", &label
->where
,
8282 /* Check whether EXPR1 has the same shape as EXPR2. */
8285 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8287 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8288 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8289 gfc_try result
= FAILURE
;
8292 /* Compare the rank. */
8293 if (expr1
->rank
!= expr2
->rank
)
8296 /* Compare the size of each dimension. */
8297 for (i
=0; i
<expr1
->rank
; i
++)
8299 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8302 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8305 if (mpz_cmp (shape
[i
], shape2
[i
]))
8309 /* When either of the two expression is an assumed size array, we
8310 ignore the comparison of dimension sizes. */
8315 for (i
--; i
>= 0; i
--)
8317 mpz_clear (shape
[i
]);
8318 mpz_clear (shape2
[i
]);
8324 /* Check whether a WHERE assignment target or a WHERE mask expression
8325 has the same shape as the outmost WHERE mask expression. */
8328 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8334 cblock
= code
->block
;
8336 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8337 In case of nested WHERE, only the outmost one is stored. */
8338 if (mask
== NULL
) /* outmost WHERE */
8340 else /* inner WHERE */
8347 /* Check if the mask-expr has a consistent shape with the
8348 outmost WHERE mask-expr. */
8349 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8350 gfc_error ("WHERE mask at %L has inconsistent shape",
8351 &cblock
->expr1
->where
);
8354 /* the assignment statement of a WHERE statement, or the first
8355 statement in where-body-construct of a WHERE construct */
8356 cnext
= cblock
->next
;
8361 /* WHERE assignment statement */
8364 /* Check shape consistent for WHERE assignment target. */
8365 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8366 gfc_error ("WHERE assignment target at %L has "
8367 "inconsistent shape", &cnext
->expr1
->where
);
8371 case EXEC_ASSIGN_CALL
:
8372 resolve_call (cnext
);
8373 if (!cnext
->resolved_sym
->attr
.elemental
)
8374 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8375 &cnext
->ext
.actual
->expr
->where
);
8378 /* WHERE or WHERE construct is part of a where-body-construct */
8380 resolve_where (cnext
, e
);
8384 gfc_error ("Unsupported statement inside WHERE at %L",
8387 /* the next statement within the same where-body-construct */
8388 cnext
= cnext
->next
;
8390 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8391 cblock
= cblock
->block
;
8396 /* Resolve assignment in FORALL construct.
8397 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8398 FORALL index variables. */
8401 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8405 for (n
= 0; n
< nvar
; n
++)
8407 gfc_symbol
*forall_index
;
8409 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
8411 /* Check whether the assignment target is one of the FORALL index
8413 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
8414 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
8415 gfc_error ("Assignment to a FORALL index variable at %L",
8416 &code
->expr1
->where
);
8419 /* If one of the FORALL index variables doesn't appear in the
8420 assignment variable, then there could be a many-to-one
8421 assignment. Emit a warning rather than an error because the
8422 mask could be resolving this problem. */
8423 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
8424 gfc_warning ("The FORALL with index '%s' is not used on the "
8425 "left side of the assignment at %L and so might "
8426 "cause multiple assignment to this object",
8427 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
8433 /* Resolve WHERE statement in FORALL construct. */
8436 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
8437 gfc_expr
**var_expr
)
8442 cblock
= code
->block
;
8445 /* the assignment statement of a WHERE statement, or the first
8446 statement in where-body-construct of a WHERE construct */
8447 cnext
= cblock
->next
;
8452 /* WHERE assignment statement */
8454 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
8457 /* WHERE operator assignment statement */
8458 case EXEC_ASSIGN_CALL
:
8459 resolve_call (cnext
);
8460 if (!cnext
->resolved_sym
->attr
.elemental
)
8461 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8462 &cnext
->ext
.actual
->expr
->where
);
8465 /* WHERE or WHERE construct is part of a where-body-construct */
8467 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
8471 gfc_error ("Unsupported statement inside WHERE at %L",
8474 /* the next statement within the same where-body-construct */
8475 cnext
= cnext
->next
;
8477 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8478 cblock
= cblock
->block
;
8483 /* Traverse the FORALL body to check whether the following errors exist:
8484 1. For assignment, check if a many-to-one assignment happens.
8485 2. For WHERE statement, check the WHERE body to see if there is any
8486 many-to-one assignment. */
8489 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
8493 c
= code
->block
->next
;
8499 case EXEC_POINTER_ASSIGN
:
8500 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
8503 case EXEC_ASSIGN_CALL
:
8507 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
8508 there is no need to handle it here. */
8512 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
8517 /* The next statement in the FORALL body. */
8523 /* Counts the number of iterators needed inside a forall construct, including
8524 nested forall constructs. This is used to allocate the needed memory
8525 in gfc_resolve_forall. */
8528 gfc_count_forall_iterators (gfc_code
*code
)
8530 int max_iters
, sub_iters
, current_iters
;
8531 gfc_forall_iterator
*fa
;
8533 gcc_assert(code
->op
== EXEC_FORALL
);
8537 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8540 code
= code
->block
->next
;
8544 if (code
->op
== EXEC_FORALL
)
8546 sub_iters
= gfc_count_forall_iterators (code
);
8547 if (sub_iters
> max_iters
)
8548 max_iters
= sub_iters
;
8553 return current_iters
+ max_iters
;
8557 /* Given a FORALL construct, first resolve the FORALL iterator, then call
8558 gfc_resolve_forall_body to resolve the FORALL body. */
8561 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
8563 static gfc_expr
**var_expr
;
8564 static int total_var
= 0;
8565 static int nvar
= 0;
8567 gfc_forall_iterator
*fa
;
8572 /* Start to resolve a FORALL construct */
8573 if (forall_save
== 0)
8575 /* Count the total number of FORALL index in the nested FORALL
8576 construct in order to allocate the VAR_EXPR with proper size. */
8577 total_var
= gfc_count_forall_iterators (code
);
8579 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
8580 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
8583 /* The information about FORALL iterator, including FORALL index start, end
8584 and stride. The FORALL index can not appear in start, end or stride. */
8585 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
8587 /* Check if any outer FORALL index name is the same as the current
8589 for (i
= 0; i
< nvar
; i
++)
8591 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
8593 gfc_error ("An outer FORALL construct already has an index "
8594 "with this name %L", &fa
->var
->where
);
8598 /* Record the current FORALL index. */
8599 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
8603 /* No memory leak. */
8604 gcc_assert (nvar
<= total_var
);
8607 /* Resolve the FORALL body. */
8608 gfc_resolve_forall_body (code
, nvar
, var_expr
);
8610 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
8611 gfc_resolve_blocks (code
->block
, ns
);
8615 /* Free only the VAR_EXPRs allocated in this frame. */
8616 for (i
= nvar
; i
< tmp
; i
++)
8617 gfc_free_expr (var_expr
[i
]);
8621 /* We are in the outermost FORALL construct. */
8622 gcc_assert (forall_save
== 0);
8624 /* VAR_EXPR is not needed any more. */
8625 gfc_free (var_expr
);
8631 /* Resolve a BLOCK construct statement. */
8634 resolve_block_construct (gfc_code
* code
)
8636 /* Resolve the BLOCK's namespace. */
8637 gfc_resolve (code
->ext
.block
.ns
);
8639 /* For an ASSOCIATE block, the associations (and their targets) are already
8640 resolved during resolve_symbol. */
8644 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
8647 static void resolve_code (gfc_code
*, gfc_namespace
*);
8650 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
8654 for (; b
; b
= b
->block
)
8656 t
= gfc_resolve_expr (b
->expr1
);
8657 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
8663 if (t
== SUCCESS
&& b
->expr1
!= NULL
8664 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
8665 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8672 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
8673 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
8678 resolve_branch (b
->label1
, b
);
8682 resolve_block_construct (b
);
8686 case EXEC_SELECT_TYPE
:
8697 case EXEC_OMP_ATOMIC
:
8698 case EXEC_OMP_CRITICAL
:
8700 case EXEC_OMP_MASTER
:
8701 case EXEC_OMP_ORDERED
:
8702 case EXEC_OMP_PARALLEL
:
8703 case EXEC_OMP_PARALLEL_DO
:
8704 case EXEC_OMP_PARALLEL_SECTIONS
:
8705 case EXEC_OMP_PARALLEL_WORKSHARE
:
8706 case EXEC_OMP_SECTIONS
:
8707 case EXEC_OMP_SINGLE
:
8709 case EXEC_OMP_TASKWAIT
:
8710 case EXEC_OMP_WORKSHARE
:
8714 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
8717 resolve_code (b
->next
, ns
);
8722 /* Does everything to resolve an ordinary assignment. Returns true
8723 if this is an interface assignment. */
8725 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
8735 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
8739 if (code
->op
== EXEC_ASSIGN_CALL
)
8741 lhs
= code
->ext
.actual
->expr
;
8742 rhsptr
= &code
->ext
.actual
->next
->expr
;
8746 gfc_actual_arglist
* args
;
8747 gfc_typebound_proc
* tbp
;
8749 gcc_assert (code
->op
== EXEC_COMPCALL
);
8751 args
= code
->expr1
->value
.compcall
.actual
;
8753 rhsptr
= &args
->next
->expr
;
8755 tbp
= code
->expr1
->value
.compcall
.tbp
;
8756 gcc_assert (!tbp
->is_generic
);
8759 /* Make a temporary rhs when there is a default initializer
8760 and rhs is the same symbol as the lhs. */
8761 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
8762 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
8763 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
8764 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
8765 *rhsptr
= gfc_get_parentheses (*rhsptr
);
8774 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
8775 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
8776 &code
->loc
) == FAILURE
)
8779 /* Handle the case of a BOZ literal on the RHS. */
8780 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
8783 if (gfc_option
.warn_surprising
)
8784 gfc_warning ("BOZ literal at %L is bitwise transferred "
8785 "non-integer symbol '%s'", &code
->loc
,
8786 lhs
->symtree
->n
.sym
->name
);
8788 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
8790 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
8792 if (rc
== ARITH_UNDERFLOW
)
8793 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
8794 ". This check can be disabled with the option "
8795 "-fno-range-check", &rhs
->where
);
8796 else if (rc
== ARITH_OVERFLOW
)
8797 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
8798 ". This check can be disabled with the option "
8799 "-fno-range-check", &rhs
->where
);
8800 else if (rc
== ARITH_NAN
)
8801 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
8802 ". This check can be disabled with the option "
8803 "-fno-range-check", &rhs
->where
);
8808 if (lhs
->ts
.type
== BT_CHARACTER
8809 && gfc_option
.warn_character_truncation
)
8811 if (lhs
->ts
.u
.cl
!= NULL
8812 && lhs
->ts
.u
.cl
->length
!= NULL
8813 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8814 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
8816 if (rhs
->expr_type
== EXPR_CONSTANT
)
8817 rlen
= rhs
->value
.character
.length
;
8819 else if (rhs
->ts
.u
.cl
!= NULL
8820 && rhs
->ts
.u
.cl
->length
!= NULL
8821 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
8822 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
8824 if (rlen
&& llen
&& rlen
> llen
)
8825 gfc_warning_now ("CHARACTER expression will be truncated "
8826 "in assignment (%d/%d) at %L",
8827 llen
, rlen
, &code
->loc
);
8830 /* Ensure that a vector index expression for the lvalue is evaluated
8831 to a temporary if the lvalue symbol is referenced in it. */
8834 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
8835 if (ref
->type
== REF_ARRAY
)
8837 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
8838 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
8839 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
8840 ref
->u
.ar
.start
[n
]))
8842 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
8846 if (gfc_pure (NULL
))
8848 if (lhs
->ts
.type
== BT_DERIVED
8849 && lhs
->expr_type
== EXPR_VARIABLE
8850 && lhs
->ts
.u
.derived
->attr
.pointer_comp
8851 && rhs
->expr_type
== EXPR_VARIABLE
8852 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
8853 || gfc_is_coindexed (rhs
)))
8856 if (gfc_is_coindexed (rhs
))
8857 gfc_error ("Coindexed expression at %L is assigned to "
8858 "a derived type variable with a POINTER "
8859 "component in a PURE procedure",
8862 gfc_error ("The impure variable at %L is assigned to "
8863 "a derived type variable with a POINTER "
8864 "component in a PURE procedure (12.6)",
8869 /* Fortran 2008, C1283. */
8870 if (gfc_is_coindexed (lhs
))
8872 gfc_error ("Assignment to coindexed variable at %L in a PURE "
8873 "procedure", &rhs
->where
);
8878 if (gfc_implicit_pure (NULL
))
8880 if (lhs
->expr_type
== EXPR_VARIABLE
8881 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
8882 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
8883 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
8885 if (lhs
->ts
.type
== BT_DERIVED
8886 && lhs
->expr_type
== EXPR_VARIABLE
8887 && lhs
->ts
.u
.derived
->attr
.pointer_comp
8888 && rhs
->expr_type
== EXPR_VARIABLE
8889 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
8890 || gfc_is_coindexed (rhs
)))
8891 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
8893 /* Fortran 2008, C1283. */
8894 if (gfc_is_coindexed (lhs
))
8895 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
8899 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
8900 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
8901 if (lhs
->ts
.type
== BT_CLASS
)
8903 gfc_error ("Variable must not be polymorphic in assignment at %L",
8908 /* F2008, Section 7.2.1.2. */
8909 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
8911 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
8912 "component in assignment at %L", &lhs
->where
);
8916 gfc_check_assign (lhs
, rhs
, 1);
8921 /* Given a block of code, recursively resolve everything pointed to by this
8925 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
8927 int omp_workshare_save
;
8932 frame
.prev
= cs_base
;
8936 find_reachable_labels (code
);
8938 for (; code
; code
= code
->next
)
8940 frame
.current
= code
;
8941 forall_save
= forall_flag
;
8943 if (code
->op
== EXEC_FORALL
)
8946 gfc_resolve_forall (code
, ns
, forall_save
);
8949 else if (code
->block
)
8951 omp_workshare_save
= -1;
8954 case EXEC_OMP_PARALLEL_WORKSHARE
:
8955 omp_workshare_save
= omp_workshare_flag
;
8956 omp_workshare_flag
= 1;
8957 gfc_resolve_omp_parallel_blocks (code
, ns
);
8959 case EXEC_OMP_PARALLEL
:
8960 case EXEC_OMP_PARALLEL_DO
:
8961 case EXEC_OMP_PARALLEL_SECTIONS
:
8963 omp_workshare_save
= omp_workshare_flag
;
8964 omp_workshare_flag
= 0;
8965 gfc_resolve_omp_parallel_blocks (code
, ns
);
8968 gfc_resolve_omp_do_blocks (code
, ns
);
8970 case EXEC_SELECT_TYPE
:
8971 /* Blocks are handled in resolve_select_type because we have
8972 to transform the SELECT TYPE into ASSOCIATE first. */
8974 case EXEC_OMP_WORKSHARE
:
8975 omp_workshare_save
= omp_workshare_flag
;
8976 omp_workshare_flag
= 1;
8979 gfc_resolve_blocks (code
->block
, ns
);
8983 if (omp_workshare_save
!= -1)
8984 omp_workshare_flag
= omp_workshare_save
;
8988 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
8989 t
= gfc_resolve_expr (code
->expr1
);
8990 forall_flag
= forall_save
;
8992 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
8995 if (code
->op
== EXEC_ALLOCATE
8996 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9002 case EXEC_END_BLOCK
:
9006 case EXEC_ERROR_STOP
:
9010 case EXEC_ASSIGN_CALL
:
9015 case EXEC_SYNC_IMAGES
:
9016 case EXEC_SYNC_MEMORY
:
9017 resolve_sync (code
);
9021 /* Keep track of which entry we are up to. */
9022 current_entry_id
= code
->ext
.entry
->id
;
9026 resolve_where (code
, NULL
);
9030 if (code
->expr1
!= NULL
)
9032 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9033 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9034 "INTEGER variable", &code
->expr1
->where
);
9035 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9036 gfc_error ("Variable '%s' has not been assigned a target "
9037 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9038 &code
->expr1
->where
);
9041 resolve_branch (code
->label1
, code
);
9045 if (code
->expr1
!= NULL
9046 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9047 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9048 "INTEGER return specifier", &code
->expr1
->where
);
9051 case EXEC_INIT_ASSIGN
:
9052 case EXEC_END_PROCEDURE
:
9059 if (gfc_check_vardef_context (code
->expr1
, false, _("assignment"))
9063 if (resolve_ordinary_assign (code
, ns
))
9065 if (code
->op
== EXEC_COMPCALL
)
9072 case EXEC_LABEL_ASSIGN
:
9073 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9074 gfc_error ("Label %d referenced at %L is never defined",
9075 code
->label1
->value
, &code
->label1
->where
);
9077 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9078 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9079 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9080 != gfc_default_integer_kind
9081 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9082 gfc_error ("ASSIGN statement at %L requires a scalar "
9083 "default INTEGER variable", &code
->expr1
->where
);
9086 case EXEC_POINTER_ASSIGN
:
9093 /* This is both a variable definition and pointer assignment
9094 context, so check both of them. For rank remapping, a final
9095 array ref may be present on the LHS and fool gfc_expr_attr
9096 used in gfc_check_vardef_context. Remove it. */
9097 e
= remove_last_array_ref (code
->expr1
);
9098 t
= gfc_check_vardef_context (e
, true, _("pointer assignment"));
9100 t
= gfc_check_vardef_context (e
, false, _("pointer assignment"));
9105 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9109 case EXEC_ARITHMETIC_IF
:
9111 && code
->expr1
->ts
.type
!= BT_INTEGER
9112 && code
->expr1
->ts
.type
!= BT_REAL
)
9113 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9114 "expression", &code
->expr1
->where
);
9116 resolve_branch (code
->label1
, code
);
9117 resolve_branch (code
->label2
, code
);
9118 resolve_branch (code
->label3
, code
);
9122 if (t
== SUCCESS
&& code
->expr1
!= NULL
9123 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9124 || code
->expr1
->rank
!= 0))
9125 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9126 &code
->expr1
->where
);
9131 resolve_call (code
);
9136 resolve_typebound_subroutine (code
);
9140 resolve_ppc_call (code
);
9144 /* Select is complicated. Also, a SELECT construct could be
9145 a transformed computed GOTO. */
9146 resolve_select (code
);
9149 case EXEC_SELECT_TYPE
:
9150 resolve_select_type (code
, ns
);
9154 resolve_block_construct (code
);
9158 if (code
->ext
.iterator
!= NULL
)
9160 gfc_iterator
*iter
= code
->ext
.iterator
;
9161 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9162 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9167 if (code
->expr1
== NULL
)
9168 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9170 && (code
->expr1
->rank
!= 0
9171 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9172 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9173 "a scalar LOGICAL expression", &code
->expr1
->where
);
9178 resolve_allocate_deallocate (code
, "ALLOCATE");
9182 case EXEC_DEALLOCATE
:
9184 resolve_allocate_deallocate (code
, "DEALLOCATE");
9189 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9192 resolve_branch (code
->ext
.open
->err
, code
);
9196 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9199 resolve_branch (code
->ext
.close
->err
, code
);
9202 case EXEC_BACKSPACE
:
9206 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9209 resolve_branch (code
->ext
.filepos
->err
, code
);
9213 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9216 resolve_branch (code
->ext
.inquire
->err
, code
);
9220 gcc_assert (code
->ext
.inquire
!= NULL
);
9221 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9224 resolve_branch (code
->ext
.inquire
->err
, code
);
9228 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9231 resolve_branch (code
->ext
.wait
->err
, code
);
9232 resolve_branch (code
->ext
.wait
->end
, code
);
9233 resolve_branch (code
->ext
.wait
->eor
, code
);
9238 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9241 resolve_branch (code
->ext
.dt
->err
, code
);
9242 resolve_branch (code
->ext
.dt
->end
, code
);
9243 resolve_branch (code
->ext
.dt
->eor
, code
);
9247 resolve_transfer (code
);
9251 resolve_forall_iterators (code
->ext
.forall_iterator
);
9253 if (code
->expr1
!= NULL
9254 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9255 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9256 "expression", &code
->expr1
->where
);
9259 case EXEC_OMP_ATOMIC
:
9260 case EXEC_OMP_BARRIER
:
9261 case EXEC_OMP_CRITICAL
:
9262 case EXEC_OMP_FLUSH
:
9264 case EXEC_OMP_MASTER
:
9265 case EXEC_OMP_ORDERED
:
9266 case EXEC_OMP_SECTIONS
:
9267 case EXEC_OMP_SINGLE
:
9268 case EXEC_OMP_TASKWAIT
:
9269 case EXEC_OMP_WORKSHARE
:
9270 gfc_resolve_omp_directive (code
, ns
);
9273 case EXEC_OMP_PARALLEL
:
9274 case EXEC_OMP_PARALLEL_DO
:
9275 case EXEC_OMP_PARALLEL_SECTIONS
:
9276 case EXEC_OMP_PARALLEL_WORKSHARE
:
9278 omp_workshare_save
= omp_workshare_flag
;
9279 omp_workshare_flag
= 0;
9280 gfc_resolve_omp_directive (code
, ns
);
9281 omp_workshare_flag
= omp_workshare_save
;
9285 gfc_internal_error ("resolve_code(): Bad statement code");
9289 cs_base
= frame
.prev
;
9293 /* Resolve initial values and make sure they are compatible with
9297 resolve_values (gfc_symbol
*sym
)
9301 if (sym
->value
== NULL
)
9304 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9305 t
= resolve_structure_cons (sym
->value
, 1);
9307 t
= gfc_resolve_expr (sym
->value
);
9312 gfc_check_assign_symbol (sym
, sym
->value
);
9316 /* Verify the binding labels for common blocks that are BIND(C). The label
9317 for a BIND(C) common block must be identical in all scoping units in which
9318 the common block is declared. Further, the binding label can not collide
9319 with any other global entity in the program. */
9322 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9324 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9326 gfc_gsymbol
*binding_label_gsym
;
9327 gfc_gsymbol
*comm_name_gsym
;
9329 /* See if a global symbol exists by the common block's name. It may
9330 be NULL if the common block is use-associated. */
9331 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9332 comm_block_tree
->n
.common
->name
);
9333 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9334 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9335 "with the global entity '%s' at %L",
9336 comm_block_tree
->n
.common
->binding_label
,
9337 comm_block_tree
->n
.common
->name
,
9338 &(comm_block_tree
->n
.common
->where
),
9339 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9340 else if (comm_name_gsym
!= NULL
9341 && strcmp (comm_name_gsym
->name
,
9342 comm_block_tree
->n
.common
->name
) == 0)
9344 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9346 if (comm_name_gsym
->binding_label
== NULL
)
9347 /* No binding label for common block stored yet; save this one. */
9348 comm_name_gsym
->binding_label
=
9349 comm_block_tree
->n
.common
->binding_label
;
9351 if (strcmp (comm_name_gsym
->binding_label
,
9352 comm_block_tree
->n
.common
->binding_label
) != 0)
9354 /* Common block names match but binding labels do not. */
9355 gfc_error ("Binding label '%s' for common block '%s' at %L "
9356 "does not match the binding label '%s' for common "
9358 comm_block_tree
->n
.common
->binding_label
,
9359 comm_block_tree
->n
.common
->name
,
9360 &(comm_block_tree
->n
.common
->where
),
9361 comm_name_gsym
->binding_label
,
9362 comm_name_gsym
->name
,
9363 &(comm_name_gsym
->where
));
9368 /* There is no binding label (NAME="") so we have nothing further to
9369 check and nothing to add as a global symbol for the label. */
9370 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
9373 binding_label_gsym
=
9374 gfc_find_gsymbol (gfc_gsym_root
,
9375 comm_block_tree
->n
.common
->binding_label
);
9376 if (binding_label_gsym
== NULL
)
9378 /* Need to make a global symbol for the binding label to prevent
9379 it from colliding with another. */
9380 binding_label_gsym
=
9381 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9382 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9383 binding_label_gsym
->type
= GSYM_COMMON
;
9387 /* If comm_name_gsym is NULL, the name common block is use
9388 associated and the name could be colliding. */
9389 if (binding_label_gsym
->type
!= GSYM_COMMON
)
9390 gfc_error ("Binding label '%s' for common block '%s' at %L "
9391 "collides with the global entity '%s' at %L",
9392 comm_block_tree
->n
.common
->binding_label
,
9393 comm_block_tree
->n
.common
->name
,
9394 &(comm_block_tree
->n
.common
->where
),
9395 binding_label_gsym
->name
,
9396 &(binding_label_gsym
->where
));
9397 else if (comm_name_gsym
!= NULL
9398 && (strcmp (binding_label_gsym
->name
,
9399 comm_name_gsym
->binding_label
) != 0)
9400 && (strcmp (binding_label_gsym
->sym_name
,
9401 comm_name_gsym
->name
) != 0))
9402 gfc_error ("Binding label '%s' for common block '%s' at %L "
9403 "collides with global entity '%s' at %L",
9404 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
9405 &(comm_block_tree
->n
.common
->where
),
9406 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9414 /* Verify any BIND(C) derived types in the namespace so we can report errors
9415 for them once, rather than for each variable declared of that type. */
9418 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
9420 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
9421 && derived_sym
->attr
.is_bind_c
== 1)
9422 verify_bind_c_derived_type (derived_sym
);
9428 /* Verify that any binding labels used in a given namespace do not collide
9429 with the names or binding labels of any global symbols. */
9432 gfc_verify_binding_labels (gfc_symbol
*sym
)
9436 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
9437 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
9439 gfc_gsymbol
*bind_c_sym
;
9441 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
9442 if (bind_c_sym
!= NULL
9443 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
9445 if (sym
->attr
.if_source
== IFSRC_DECL
9446 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
9447 && bind_c_sym
->type
!= GSYM_FUNCTION
)
9448 && ((sym
->attr
.contained
== 1
9449 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
9450 || (sym
->attr
.use_assoc
== 1
9451 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
9453 /* Make sure global procedures don't collide with anything. */
9454 gfc_error ("Binding label '%s' at %L collides with the global "
9455 "entity '%s' at %L", sym
->binding_label
,
9456 &(sym
->declared_at
), bind_c_sym
->name
,
9457 &(bind_c_sym
->where
));
9460 else if (sym
->attr
.contained
== 0
9461 && (sym
->attr
.if_source
== IFSRC_IFBODY
9462 && sym
->attr
.flavor
== FL_PROCEDURE
)
9463 && (bind_c_sym
->sym_name
!= NULL
9464 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
9466 /* Make sure procedures in interface bodies don't collide. */
9467 gfc_error ("Binding label '%s' in interface body at %L collides "
9468 "with the global entity '%s' at %L",
9470 &(sym
->declared_at
), bind_c_sym
->name
,
9471 &(bind_c_sym
->where
));
9474 else if (sym
->attr
.contained
== 0
9475 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
9476 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
9477 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
9478 || sym
->attr
.use_assoc
== 0)
9480 gfc_error ("Binding label '%s' at %L collides with global "
9481 "entity '%s' at %L", sym
->binding_label
,
9482 &(sym
->declared_at
), bind_c_sym
->name
,
9483 &(bind_c_sym
->where
));
9488 /* Clear the binding label to prevent checking multiple times. */
9489 sym
->binding_label
[0] = '\0';
9491 else if (bind_c_sym
== NULL
)
9493 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
9494 bind_c_sym
->where
= sym
->declared_at
;
9495 bind_c_sym
->sym_name
= sym
->name
;
9497 if (sym
->attr
.use_assoc
== 1)
9498 bind_c_sym
->mod_name
= sym
->module
;
9500 if (sym
->ns
->proc_name
!= NULL
)
9501 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
9503 if (sym
->attr
.contained
== 0)
9505 if (sym
->attr
.subroutine
)
9506 bind_c_sym
->type
= GSYM_SUBROUTINE
;
9507 else if (sym
->attr
.function
)
9508 bind_c_sym
->type
= GSYM_FUNCTION
;
9516 /* Resolve an index expression. */
9519 resolve_index_expr (gfc_expr
*e
)
9521 if (gfc_resolve_expr (e
) == FAILURE
)
9524 if (gfc_simplify_expr (e
, 0) == FAILURE
)
9527 if (gfc_specification_expr (e
) == FAILURE
)
9534 /* Resolve a charlen structure. */
9537 resolve_charlen (gfc_charlen
*cl
)
9546 specification_expr
= 1;
9548 if (resolve_index_expr (cl
->length
) == FAILURE
)
9550 specification_expr
= 0;
9554 /* "If the character length parameter value evaluates to a negative
9555 value, the length of character entities declared is zero." */
9556 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
9558 if (gfc_option
.warn_surprising
)
9559 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
9560 " the length has been set to zero",
9561 &cl
->length
->where
, i
);
9562 gfc_replace_expr (cl
->length
,
9563 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
9566 /* Check that the character length is not too large. */
9567 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
9568 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
9569 && cl
->length
->ts
.type
== BT_INTEGER
9570 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
9572 gfc_error ("String length at %L is too large", &cl
->length
->where
);
9580 /* Test for non-constant shape arrays. */
9583 is_non_constant_shape_array (gfc_symbol
*sym
)
9589 not_constant
= false;
9590 if (sym
->as
!= NULL
)
9592 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
9593 has not been simplified; parameter array references. Do the
9594 simplification now. */
9595 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
9597 e
= sym
->as
->lower
[i
];
9598 if (e
&& (resolve_index_expr (e
) == FAILURE
9599 || !gfc_is_constant_expr (e
)))
9600 not_constant
= true;
9601 e
= sym
->as
->upper
[i
];
9602 if (e
&& (resolve_index_expr (e
) == FAILURE
9603 || !gfc_is_constant_expr (e
)))
9604 not_constant
= true;
9607 return not_constant
;
9610 /* Given a symbol and an initialization expression, add code to initialize
9611 the symbol to the function entry. */
9613 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
9617 gfc_namespace
*ns
= sym
->ns
;
9619 /* Search for the function namespace if this is a contained
9620 function without an explicit result. */
9621 if (sym
->attr
.function
&& sym
== sym
->result
9622 && sym
->name
!= sym
->ns
->proc_name
->name
)
9625 for (;ns
; ns
= ns
->sibling
)
9626 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
9632 gfc_free_expr (init
);
9636 /* Build an l-value expression for the result. */
9637 lval
= gfc_lval_expr_from_sym (sym
);
9639 /* Add the code at scope entry. */
9640 init_st
= gfc_get_code ();
9641 init_st
->next
= ns
->code
;
9644 /* Assign the default initializer to the l-value. */
9645 init_st
->loc
= sym
->declared_at
;
9646 init_st
->op
= EXEC_INIT_ASSIGN
;
9647 init_st
->expr1
= lval
;
9648 init_st
->expr2
= init
;
9651 /* Assign the default initializer to a derived type variable or result. */
9654 apply_default_init (gfc_symbol
*sym
)
9656 gfc_expr
*init
= NULL
;
9658 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
9661 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
9662 init
= gfc_default_initializer (&sym
->ts
);
9664 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
9667 build_init_assign (sym
, init
);
9668 sym
->attr
.referenced
= 1;
9671 /* Build an initializer for a local integer, real, complex, logical, or
9672 character variable, based on the command line flags finit-local-zero,
9673 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
9674 null if the symbol should not have a default initialization. */
9676 build_default_init_expr (gfc_symbol
*sym
)
9679 gfc_expr
*init_expr
;
9682 /* These symbols should never have a default initialization. */
9683 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
9684 || sym
->attr
.external
9686 || sym
->attr
.pointer
9687 || sym
->attr
.in_equivalence
9688 || sym
->attr
.in_common
9691 || sym
->attr
.cray_pointee
9692 || sym
->attr
.cray_pointer
)
9695 /* Now we'll try to build an initializer expression. */
9696 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
9699 /* We will only initialize integers, reals, complex, logicals, and
9700 characters, and only if the corresponding command-line flags
9701 were set. Otherwise, we free init_expr and return null. */
9702 switch (sym
->ts
.type
)
9705 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
9706 mpz_set_si (init_expr
->value
.integer
,
9707 gfc_option
.flag_init_integer_value
);
9710 gfc_free_expr (init_expr
);
9716 switch (gfc_option
.flag_init_real
)
9718 case GFC_INIT_REAL_SNAN
:
9719 init_expr
->is_snan
= 1;
9721 case GFC_INIT_REAL_NAN
:
9722 mpfr_set_nan (init_expr
->value
.real
);
9725 case GFC_INIT_REAL_INF
:
9726 mpfr_set_inf (init_expr
->value
.real
, 1);
9729 case GFC_INIT_REAL_NEG_INF
:
9730 mpfr_set_inf (init_expr
->value
.real
, -1);
9733 case GFC_INIT_REAL_ZERO
:
9734 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
9738 gfc_free_expr (init_expr
);
9745 switch (gfc_option
.flag_init_real
)
9747 case GFC_INIT_REAL_SNAN
:
9748 init_expr
->is_snan
= 1;
9750 case GFC_INIT_REAL_NAN
:
9751 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
9752 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
9755 case GFC_INIT_REAL_INF
:
9756 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
9757 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
9760 case GFC_INIT_REAL_NEG_INF
:
9761 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
9762 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
9765 case GFC_INIT_REAL_ZERO
:
9766 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
9770 gfc_free_expr (init_expr
);
9777 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
9778 init_expr
->value
.logical
= 0;
9779 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
9780 init_expr
->value
.logical
= 1;
9783 gfc_free_expr (init_expr
);
9789 /* For characters, the length must be constant in order to
9790 create a default initializer. */
9791 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
9792 && sym
->ts
.u
.cl
->length
9793 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9795 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
9796 init_expr
->value
.character
.length
= char_len
;
9797 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
9798 for (i
= 0; i
< char_len
; i
++)
9799 init_expr
->value
.character
.string
[i
]
9800 = (unsigned char) gfc_option
.flag_init_character_value
;
9804 gfc_free_expr (init_expr
);
9810 gfc_free_expr (init_expr
);
9816 /* Add an initialization expression to a local variable. */
9818 apply_default_init_local (gfc_symbol
*sym
)
9820 gfc_expr
*init
= NULL
;
9822 /* The symbol should be a variable or a function return value. */
9823 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
9824 || (sym
->attr
.function
&& sym
->result
!= sym
))
9827 /* Try to build the initializer expression. If we can't initialize
9828 this symbol, then init will be NULL. */
9829 init
= build_default_init_expr (sym
);
9833 /* For saved variables, we don't want to add an initializer at
9834 function entry, so we just add a static initializer. */
9835 if (sym
->attr
.save
|| sym
->ns
->save_all
9836 || gfc_option
.flag_max_stack_var_size
== 0)
9838 /* Don't clobber an existing initializer! */
9839 gcc_assert (sym
->value
== NULL
);
9844 build_init_assign (sym
, init
);
9848 /* Resolution of common features of flavors variable and procedure. */
9851 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
9853 /* Constraints on deferred shape variable. */
9854 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
9856 if (sym
->attr
.allocatable
)
9858 if (sym
->attr
.dimension
)
9860 gfc_error ("Allocatable array '%s' at %L must have "
9861 "a deferred shape", sym
->name
, &sym
->declared_at
);
9864 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object '%s' at %L "
9865 "may not be ALLOCATABLE", sym
->name
,
9866 &sym
->declared_at
) == FAILURE
)
9870 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
9872 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
9873 sym
->name
, &sym
->declared_at
);
9879 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
9880 && !sym
->attr
.dummy
&& sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
9882 gfc_error ("Array '%s' at %L cannot have a deferred shape",
9883 sym
->name
, &sym
->declared_at
);
9888 /* Constraints on polymorphic variables. */
9889 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
9892 if (sym
->attr
.class_ok
9893 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
9895 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
9896 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
9902 /* Assume that use associated symbols were checked in the module ns.
9903 Class-variables that are associate-names are also something special
9904 and excepted from the test. */
9905 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
9907 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
9908 "or pointer", sym
->name
, &sym
->declared_at
);
9917 /* Additional checks for symbols with flavor variable and derived
9918 type. To be called from resolve_fl_variable. */
9921 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
9923 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
9925 /* Check to see if a derived type is blocked from being host
9926 associated by the presence of another class I symbol in the same
9927 namespace. 14.6.1.3 of the standard and the discussion on
9928 comp.lang.fortran. */
9929 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
9930 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
9933 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
9934 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
9936 gfc_error ("The type '%s' cannot be host associated at %L "
9937 "because it is blocked by an incompatible object "
9938 "of the same name declared at %L",
9939 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
9945 /* 4th constraint in section 11.3: "If an object of a type for which
9946 component-initialization is specified (R429) appears in the
9947 specification-part of a module and does not have the ALLOCATABLE
9948 or POINTER attribute, the object shall have the SAVE attribute."
9950 The check for initializers is performed with
9951 gfc_has_default_initializer because gfc_default_initializer generates
9952 a hidden default for allocatable components. */
9953 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
9954 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
9955 && !sym
->ns
->save_all
&& !sym
->attr
.save
9956 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
9957 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
9958 && gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Implied SAVE for "
9959 "module variable '%s' at %L, needed due to "
9960 "the default initialization", sym
->name
,
9961 &sym
->declared_at
) == FAILURE
)
9964 /* Assign default initializer. */
9965 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
9966 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
9968 sym
->value
= gfc_default_initializer (&sym
->ts
);
9975 /* Resolve symbols with flavor variable. */
9978 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
9980 int no_init_flag
, automatic_flag
;
9982 const char *auto_save_msg
;
9984 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
9987 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
9990 /* Set this flag to check that variables are parameters of all entries.
9991 This check is effected by the call to gfc_resolve_expr through
9992 is_non_constant_shape_array. */
9993 specification_expr
= 1;
9995 if (sym
->ns
->proc_name
9996 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
9997 || sym
->ns
->proc_name
->attr
.is_main_program
)
9998 && !sym
->attr
.use_assoc
9999 && !sym
->attr
.allocatable
10000 && !sym
->attr
.pointer
10001 && is_non_constant_shape_array (sym
))
10003 /* The shape of a main program or module array needs to be
10005 gfc_error ("The module or main program array '%s' at %L must "
10006 "have constant shape", sym
->name
, &sym
->declared_at
);
10007 specification_expr
= 0;
10011 /* Constraints on deferred type parameter. */
10012 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10014 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10015 "requires either the pointer or allocatable attribute",
10016 sym
->name
, &sym
->declared_at
);
10020 if (sym
->ts
.type
== BT_CHARACTER
)
10022 /* Make sure that character string variables with assumed length are
10023 dummy arguments. */
10024 e
= sym
->ts
.u
.cl
->length
;
10025 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10026 && !sym
->ts
.deferred
)
10028 gfc_error ("Entity with assumed character length at %L must be a "
10029 "dummy argument or a PARAMETER", &sym
->declared_at
);
10033 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10035 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10039 if (!gfc_is_constant_expr (e
)
10040 && !(e
->expr_type
== EXPR_VARIABLE
10041 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
10042 && sym
->ns
->proc_name
10043 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10044 || sym
->ns
->proc_name
->attr
.is_main_program
)
10045 && !sym
->attr
.use_assoc
)
10047 gfc_error ("'%s' at %L must have constant character length "
10048 "in this context", sym
->name
, &sym
->declared_at
);
10053 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10054 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10056 /* Determine if the symbol may not have an initializer. */
10057 no_init_flag
= automatic_flag
= 0;
10058 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10059 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10061 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10062 && is_non_constant_shape_array (sym
))
10064 no_init_flag
= automatic_flag
= 1;
10066 /* Also, they must not have the SAVE attribute.
10067 SAVE_IMPLICIT is checked below. */
10068 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10070 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10075 /* Ensure that any initializer is simplified. */
10077 gfc_simplify_expr (sym
->value
, 1);
10079 /* Reject illegal initializers. */
10080 if (!sym
->mark
&& sym
->value
)
10082 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10083 && CLASS_DATA (sym
)->attr
.allocatable
))
10084 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10085 sym
->name
, &sym
->declared_at
);
10086 else if (sym
->attr
.external
)
10087 gfc_error ("External '%s' at %L cannot have an initializer",
10088 sym
->name
, &sym
->declared_at
);
10089 else if (sym
->attr
.dummy
10090 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10091 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10092 sym
->name
, &sym
->declared_at
);
10093 else if (sym
->attr
.intrinsic
)
10094 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10095 sym
->name
, &sym
->declared_at
);
10096 else if (sym
->attr
.result
)
10097 gfc_error ("Function result '%s' at %L cannot have an initializer",
10098 sym
->name
, &sym
->declared_at
);
10099 else if (automatic_flag
)
10100 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10101 sym
->name
, &sym
->declared_at
);
10103 goto no_init_error
;
10108 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10109 return resolve_fl_variable_derived (sym
, no_init_flag
);
10115 /* Resolve a procedure. */
10118 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10120 gfc_formal_arglist
*arg
;
10122 if (sym
->attr
.function
10123 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10126 if (sym
->ts
.type
== BT_CHARACTER
)
10128 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10130 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10131 && resolve_charlen (cl
) == FAILURE
)
10134 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10135 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10137 gfc_error ("Character-valued statement function '%s' at %L must "
10138 "have constant length", sym
->name
, &sym
->declared_at
);
10143 /* Ensure that derived type for are not of a private type. Internal
10144 module procedures are excluded by 2.2.3.3 - i.e., they are not
10145 externally accessible and can access all the objects accessible in
10147 if (!(sym
->ns
->parent
10148 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10149 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
10151 gfc_interface
*iface
;
10153 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10156 && arg
->sym
->ts
.type
== BT_DERIVED
10157 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10158 && !gfc_check_access (arg
->sym
->ts
.u
.derived
->attr
.access
,
10159 arg
->sym
->ts
.u
.derived
->ns
->default_access
)
10160 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
10161 "PRIVATE type and cannot be a dummy argument"
10162 " of '%s', which is PUBLIC at %L",
10163 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10166 /* Stop this message from recurring. */
10167 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10172 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10173 PRIVATE to the containing module. */
10174 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10176 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10179 && arg
->sym
->ts
.type
== BT_DERIVED
10180 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10181 && !gfc_check_access (arg
->sym
->ts
.u
.derived
->attr
.access
,
10182 arg
->sym
->ts
.u
.derived
->ns
->default_access
)
10183 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10184 "'%s' in PUBLIC interface '%s' at %L "
10185 "takes dummy arguments of '%s' which is "
10186 "PRIVATE", iface
->sym
->name
, sym
->name
,
10187 &iface
->sym
->declared_at
,
10188 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10190 /* Stop this message from recurring. */
10191 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10197 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10198 PRIVATE to the containing module. */
10199 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10201 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10204 && arg
->sym
->ts
.type
== BT_DERIVED
10205 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10206 && !gfc_check_access (arg
->sym
->ts
.u
.derived
->attr
.access
,
10207 arg
->sym
->ts
.u
.derived
->ns
->default_access
)
10208 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
10209 "'%s' in PUBLIC interface '%s' at %L "
10210 "takes dummy arguments of '%s' which is "
10211 "PRIVATE", iface
->sym
->name
, sym
->name
,
10212 &iface
->sym
->declared_at
,
10213 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10215 /* Stop this message from recurring. */
10216 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10223 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10224 && !sym
->attr
.proc_pointer
)
10226 gfc_error ("Function '%s' at %L cannot have an initializer",
10227 sym
->name
, &sym
->declared_at
);
10231 /* An external symbol may not have an initializer because it is taken to be
10232 a procedure. Exception: Procedure Pointers. */
10233 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10235 gfc_error ("External object '%s' at %L may not have an initializer",
10236 sym
->name
, &sym
->declared_at
);
10240 /* An elemental function is required to return a scalar 12.7.1 */
10241 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10243 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10244 "result", sym
->name
, &sym
->declared_at
);
10245 /* Reset so that the error only occurs once. */
10246 sym
->attr
.elemental
= 0;
10250 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10251 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10253 gfc_error ("Statement function '%s' at %L may not have pointer or "
10254 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10258 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10259 char-len-param shall not be array-valued, pointer-valued, recursive
10260 or pure. ....snip... A character value of * may only be used in the
10261 following ways: (i) Dummy arg of procedure - dummy associates with
10262 actual length; (ii) To declare a named constant; or (iii) External
10263 function - but length must be declared in calling scoping unit. */
10264 if (sym
->attr
.function
10265 && sym
->ts
.type
== BT_CHARACTER
10266 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10268 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10269 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10271 if (sym
->as
&& sym
->as
->rank
)
10272 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10273 "array-valued", sym
->name
, &sym
->declared_at
);
10275 if (sym
->attr
.pointer
)
10276 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10277 "pointer-valued", sym
->name
, &sym
->declared_at
);
10279 if (sym
->attr
.pure
)
10280 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10281 "pure", sym
->name
, &sym
->declared_at
);
10283 if (sym
->attr
.recursive
)
10284 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10285 "recursive", sym
->name
, &sym
->declared_at
);
10290 /* Appendix B.2 of the standard. Contained functions give an
10291 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10292 character length is an F2003 feature. */
10293 if (!sym
->attr
.contained
10294 && gfc_current_form
!= FORM_FIXED
10295 && !sym
->ts
.deferred
)
10296 gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
10297 "CHARACTER(*) function '%s' at %L",
10298 sym
->name
, &sym
->declared_at
);
10301 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10303 gfc_formal_arglist
*curr_arg
;
10304 int has_non_interop_arg
= 0;
10306 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10307 sym
->common_block
) == FAILURE
)
10309 /* Clear these to prevent looking at them again if there was an
10311 sym
->attr
.is_bind_c
= 0;
10312 sym
->attr
.is_c_interop
= 0;
10313 sym
->ts
.is_c_interop
= 0;
10317 /* So far, no errors have been found. */
10318 sym
->attr
.is_c_interop
= 1;
10319 sym
->ts
.is_c_interop
= 1;
10322 curr_arg
= sym
->formal
;
10323 while (curr_arg
!= NULL
)
10325 /* Skip implicitly typed dummy args here. */
10326 if (curr_arg
->sym
->attr
.implicit_type
== 0)
10327 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
10328 /* If something is found to fail, record the fact so we
10329 can mark the symbol for the procedure as not being
10330 BIND(C) to try and prevent multiple errors being
10332 has_non_interop_arg
= 1;
10334 curr_arg
= curr_arg
->next
;
10337 /* See if any of the arguments were not interoperable and if so, clear
10338 the procedure symbol to prevent duplicate error messages. */
10339 if (has_non_interop_arg
!= 0)
10341 sym
->attr
.is_c_interop
= 0;
10342 sym
->ts
.is_c_interop
= 0;
10343 sym
->attr
.is_bind_c
= 0;
10347 if (!sym
->attr
.proc_pointer
)
10349 if (sym
->attr
.save
== SAVE_EXPLICIT
)
10351 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
10352 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10355 if (sym
->attr
.intent
)
10357 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
10358 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10361 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
10363 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
10364 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10367 if (sym
->attr
.external
&& sym
->attr
.function
10368 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
10369 || sym
->attr
.contained
))
10371 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
10372 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
10375 if (strcmp ("ppr@", sym
->name
) == 0)
10377 gfc_error ("Procedure pointer result '%s' at %L "
10378 "is missing the pointer attribute",
10379 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
10388 /* Resolve a list of finalizer procedures. That is, after they have hopefully
10389 been defined and we now know their defined arguments, check that they fulfill
10390 the requirements of the standard for procedures used as finalizers. */
10393 gfc_resolve_finalizers (gfc_symbol
* derived
)
10395 gfc_finalizer
* list
;
10396 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
10397 gfc_try result
= SUCCESS
;
10398 bool seen_scalar
= false;
10400 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
10403 /* Walk over the list of finalizer-procedures, check them, and if any one
10404 does not fit in with the standard's definition, print an error and remove
10405 it from the list. */
10406 prev_link
= &derived
->f2k_derived
->finalizers
;
10407 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
10413 /* Skip this finalizer if we already resolved it. */
10414 if (list
->proc_tree
)
10416 prev_link
= &(list
->next
);
10420 /* Check this exists and is a SUBROUTINE. */
10421 if (!list
->proc_sym
->attr
.subroutine
)
10423 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
10424 list
->proc_sym
->name
, &list
->where
);
10428 /* We should have exactly one argument. */
10429 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
10431 gfc_error ("FINAL procedure at %L must have exactly one argument",
10435 arg
= list
->proc_sym
->formal
->sym
;
10437 /* This argument must be of our type. */
10438 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
10440 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
10441 &arg
->declared_at
, derived
->name
);
10445 /* It must neither be a pointer nor allocatable nor optional. */
10446 if (arg
->attr
.pointer
)
10448 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
10449 &arg
->declared_at
);
10452 if (arg
->attr
.allocatable
)
10454 gfc_error ("Argument of FINAL procedure at %L must not be"
10455 " ALLOCATABLE", &arg
->declared_at
);
10458 if (arg
->attr
.optional
)
10460 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
10461 &arg
->declared_at
);
10465 /* It must not be INTENT(OUT). */
10466 if (arg
->attr
.intent
== INTENT_OUT
)
10468 gfc_error ("Argument of FINAL procedure at %L must not be"
10469 " INTENT(OUT)", &arg
->declared_at
);
10473 /* Warn if the procedure is non-scalar and not assumed shape. */
10474 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
10475 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
10476 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
10477 " shape argument", &arg
->declared_at
);
10479 /* Check that it does not match in kind and rank with a FINAL procedure
10480 defined earlier. To really loop over the *earlier* declarations,
10481 we need to walk the tail of the list as new ones were pushed at the
10483 /* TODO: Handle kind parameters once they are implemented. */
10484 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
10485 for (i
= list
->next
; i
; i
= i
->next
)
10487 /* Argument list might be empty; that is an error signalled earlier,
10488 but we nevertheless continued resolving. */
10489 if (i
->proc_sym
->formal
)
10491 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
10492 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
10493 if (i_rank
== my_rank
)
10495 gfc_error ("FINAL procedure '%s' declared at %L has the same"
10496 " rank (%d) as '%s'",
10497 list
->proc_sym
->name
, &list
->where
, my_rank
,
10498 i
->proc_sym
->name
);
10504 /* Is this the/a scalar finalizer procedure? */
10505 if (!arg
->as
|| arg
->as
->rank
== 0)
10506 seen_scalar
= true;
10508 /* Find the symtree for this procedure. */
10509 gcc_assert (!list
->proc_tree
);
10510 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
10512 prev_link
= &list
->next
;
10515 /* Remove wrong nodes immediately from the list so we don't risk any
10516 troubles in the future when they might fail later expectations. */
10520 *prev_link
= list
->next
;
10521 gfc_free_finalizer (i
);
10524 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
10525 were nodes in the list, must have been for arrays. It is surely a good
10526 idea to have a scalar version there if there's something to finalize. */
10527 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
10528 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
10529 " defined at %L, suggest also scalar one",
10530 derived
->name
, &derived
->declared_at
);
10532 /* TODO: Remove this error when finalization is finished. */
10533 gfc_error ("Finalization at %L is not yet implemented",
10534 &derived
->declared_at
);
10540 /* Check that it is ok for the typebound procedure proc to override the
10544 check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
10547 const gfc_symbol
* proc_target
;
10548 const gfc_symbol
* old_target
;
10549 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
10550 gfc_formal_arglist
* proc_formal
;
10551 gfc_formal_arglist
* old_formal
;
10553 /* This procedure should only be called for non-GENERIC proc. */
10554 gcc_assert (!proc
->n
.tb
->is_generic
);
10556 /* If the overwritten procedure is GENERIC, this is an error. */
10557 if (old
->n
.tb
->is_generic
)
10559 gfc_error ("Can't overwrite GENERIC '%s' at %L",
10560 old
->name
, &proc
->n
.tb
->where
);
10564 where
= proc
->n
.tb
->where
;
10565 proc_target
= proc
->n
.tb
->u
.specific
->n
.sym
;
10566 old_target
= old
->n
.tb
->u
.specific
->n
.sym
;
10568 /* Check that overridden binding is not NON_OVERRIDABLE. */
10569 if (old
->n
.tb
->non_overridable
)
10571 gfc_error ("'%s' at %L overrides a procedure binding declared"
10572 " NON_OVERRIDABLE", proc
->name
, &where
);
10576 /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
10577 if (!old
->n
.tb
->deferred
&& proc
->n
.tb
->deferred
)
10579 gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
10580 " non-DEFERRED binding", proc
->name
, &where
);
10584 /* If the overridden binding is PURE, the overriding must be, too. */
10585 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
10587 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
10588 proc
->name
, &where
);
10592 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
10593 is not, the overriding must not be either. */
10594 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
10596 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
10597 " ELEMENTAL", proc
->name
, &where
);
10600 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
10602 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
10603 " be ELEMENTAL, either", proc
->name
, &where
);
10607 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
10609 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
10611 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
10612 " SUBROUTINE", proc
->name
, &where
);
10616 /* If the overridden binding is a FUNCTION, the overriding must also be a
10617 FUNCTION and have the same characteristics. */
10618 if (old_target
->attr
.function
)
10620 if (!proc_target
->attr
.function
)
10622 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
10623 " FUNCTION", proc
->name
, &where
);
10627 /* FIXME: Do more comprehensive checking (including, for instance, the
10628 rank and array-shape). */
10629 gcc_assert (proc_target
->result
&& old_target
->result
);
10630 if (!gfc_compare_types (&proc_target
->result
->ts
,
10631 &old_target
->result
->ts
))
10633 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
10634 " matching result types", proc
->name
, &where
);
10639 /* If the overridden binding is PUBLIC, the overriding one must not be
10641 if (old
->n
.tb
->access
== ACCESS_PUBLIC
10642 && proc
->n
.tb
->access
== ACCESS_PRIVATE
)
10644 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
10645 " PRIVATE", proc
->name
, &where
);
10649 /* Compare the formal argument lists of both procedures. This is also abused
10650 to find the position of the passed-object dummy arguments of both
10651 bindings as at least the overridden one might not yet be resolved and we
10652 need those positions in the check below. */
10653 proc_pass_arg
= old_pass_arg
= 0;
10654 if (!proc
->n
.tb
->nopass
&& !proc
->n
.tb
->pass_arg
)
10656 if (!old
->n
.tb
->nopass
&& !old
->n
.tb
->pass_arg
)
10659 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
10660 proc_formal
&& old_formal
;
10661 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
10663 if (proc
->n
.tb
->pass_arg
10664 && !strcmp (proc
->n
.tb
->pass_arg
, proc_formal
->sym
->name
))
10665 proc_pass_arg
= argpos
;
10666 if (old
->n
.tb
->pass_arg
10667 && !strcmp (old
->n
.tb
->pass_arg
, old_formal
->sym
->name
))
10668 old_pass_arg
= argpos
;
10670 /* Check that the names correspond. */
10671 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
10673 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
10674 " to match the corresponding argument of the overridden"
10675 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
10676 old_formal
->sym
->name
);
10680 /* Check that the types correspond if neither is the passed-object
10682 /* FIXME: Do more comprehensive testing here. */
10683 if (proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
10684 && !gfc_compare_types (&proc_formal
->sym
->ts
, &old_formal
->sym
->ts
))
10686 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
10687 "in respect to the overridden procedure",
10688 proc_formal
->sym
->name
, proc
->name
, &where
);
10694 if (proc_formal
|| old_formal
)
10696 gfc_error ("'%s' at %L must have the same number of formal arguments as"
10697 " the overridden procedure", proc
->name
, &where
);
10701 /* If the overridden binding is NOPASS, the overriding one must also be
10703 if (old
->n
.tb
->nopass
&& !proc
->n
.tb
->nopass
)
10705 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
10706 " NOPASS", proc
->name
, &where
);
10710 /* If the overridden binding is PASS(x), the overriding one must also be
10711 PASS and the passed-object dummy arguments must correspond. */
10712 if (!old
->n
.tb
->nopass
)
10714 if (proc
->n
.tb
->nopass
)
10716 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
10717 " PASS", proc
->name
, &where
);
10721 if (proc_pass_arg
!= old_pass_arg
)
10723 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
10724 " the same position as the passed-object dummy argument of"
10725 " the overridden procedure", proc
->name
, &where
);
10734 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
10737 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
10738 const char* generic_name
, locus where
)
10743 gcc_assert (t1
->specific
&& t2
->specific
);
10744 gcc_assert (!t1
->specific
->is_generic
);
10745 gcc_assert (!t2
->specific
->is_generic
);
10747 sym1
= t1
->specific
->u
.specific
->n
.sym
;
10748 sym2
= t2
->specific
->u
.specific
->n
.sym
;
10753 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
10754 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
10755 || sym1
->attr
.function
!= sym2
->attr
.function
)
10757 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
10758 " GENERIC '%s' at %L",
10759 sym1
->name
, sym2
->name
, generic_name
, &where
);
10763 /* Compare the interfaces. */
10764 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, 1, 0, NULL
, 0))
10766 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
10767 sym1
->name
, sym2
->name
, generic_name
, &where
);
10775 /* Worker function for resolving a generic procedure binding; this is used to
10776 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
10778 The difference between those cases is finding possible inherited bindings
10779 that are overridden, as one has to look for them in tb_sym_root,
10780 tb_uop_root or tb_op, respectively. Thus the caller must already find
10781 the super-type and set p->overridden correctly. */
10784 resolve_tb_generic_targets (gfc_symbol
* super_type
,
10785 gfc_typebound_proc
* p
, const char* name
)
10787 gfc_tbp_generic
* target
;
10788 gfc_symtree
* first_target
;
10789 gfc_symtree
* inherited
;
10791 gcc_assert (p
&& p
->is_generic
);
10793 /* Try to find the specific bindings for the symtrees in our target-list. */
10794 gcc_assert (p
->u
.generic
);
10795 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10796 if (!target
->specific
)
10798 gfc_typebound_proc
* overridden_tbp
;
10799 gfc_tbp_generic
* g
;
10800 const char* target_name
;
10802 target_name
= target
->specific_st
->name
;
10804 /* Defined for this type directly. */
10805 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
10807 target
->specific
= target
->specific_st
->n
.tb
;
10808 goto specific_found
;
10811 /* Look for an inherited specific binding. */
10814 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
10819 gcc_assert (inherited
->n
.tb
);
10820 target
->specific
= inherited
->n
.tb
;
10821 goto specific_found
;
10825 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
10826 " at %L", target_name
, name
, &p
->where
);
10829 /* Once we've found the specific binding, check it is not ambiguous with
10830 other specifics already found or inherited for the same GENERIC. */
10832 gcc_assert (target
->specific
);
10834 /* This must really be a specific binding! */
10835 if (target
->specific
->is_generic
)
10837 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
10838 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
10842 /* Check those already resolved on this type directly. */
10843 for (g
= p
->u
.generic
; g
; g
= g
->next
)
10844 if (g
!= target
&& g
->specific
10845 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
10849 /* Check for ambiguity with inherited specific targets. */
10850 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
10851 overridden_tbp
= overridden_tbp
->overridden
)
10852 if (overridden_tbp
->is_generic
)
10854 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
10856 gcc_assert (g
->specific
);
10857 if (check_generic_tbp_ambiguity (target
, g
,
10858 name
, p
->where
) == FAILURE
)
10864 /* If we attempt to "overwrite" a specific binding, this is an error. */
10865 if (p
->overridden
&& !p
->overridden
->is_generic
)
10867 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
10868 " the same name", name
, &p
->where
);
10872 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
10873 all must have the same attributes here. */
10874 first_target
= p
->u
.generic
->specific
->u
.specific
;
10875 gcc_assert (first_target
);
10876 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
10877 p
->function
= first_target
->n
.sym
->attr
.function
;
10883 /* Resolve a GENERIC procedure binding for a derived type. */
10886 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
10888 gfc_symbol
* super_type
;
10890 /* Find the overridden binding if any. */
10891 st
->n
.tb
->overridden
= NULL
;
10892 super_type
= gfc_get_derived_super_type (derived
);
10895 gfc_symtree
* overridden
;
10896 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
10899 if (overridden
&& overridden
->n
.tb
)
10900 st
->n
.tb
->overridden
= overridden
->n
.tb
;
10903 /* Resolve using worker function. */
10904 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
10908 /* Retrieve the target-procedure of an operator binding and do some checks in
10909 common for intrinsic and user-defined type-bound operators. */
10912 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
10914 gfc_symbol
* target_proc
;
10916 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
10917 target_proc
= target
->specific
->u
.specific
->n
.sym
;
10918 gcc_assert (target_proc
);
10920 /* All operator bindings must have a passed-object dummy argument. */
10921 if (target
->specific
->nopass
)
10923 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
10927 return target_proc
;
10931 /* Resolve a type-bound intrinsic operator. */
10934 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
10935 gfc_typebound_proc
* p
)
10937 gfc_symbol
* super_type
;
10938 gfc_tbp_generic
* target
;
10940 /* If there's already an error here, do nothing (but don't fail again). */
10944 /* Operators should always be GENERIC bindings. */
10945 gcc_assert (p
->is_generic
);
10947 /* Look for an overridden binding. */
10948 super_type
= gfc_get_derived_super_type (derived
);
10949 if (super_type
&& super_type
->f2k_derived
)
10950 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
10953 p
->overridden
= NULL
;
10955 /* Resolve general GENERIC properties using worker function. */
10956 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
10959 /* Check the targets to be procedures of correct interface. */
10960 for (target
= p
->u
.generic
; target
; target
= target
->next
)
10962 gfc_symbol
* target_proc
;
10964 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
10968 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
10980 /* Resolve a type-bound user operator (tree-walker callback). */
10982 static gfc_symbol
* resolve_bindings_derived
;
10983 static gfc_try resolve_bindings_result
;
10985 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
10988 resolve_typebound_user_op (gfc_symtree
* stree
)
10990 gfc_symbol
* super_type
;
10991 gfc_tbp_generic
* target
;
10993 gcc_assert (stree
&& stree
->n
.tb
);
10995 if (stree
->n
.tb
->error
)
10998 /* Operators should always be GENERIC bindings. */
10999 gcc_assert (stree
->n
.tb
->is_generic
);
11001 /* Find overridden procedure, if any. */
11002 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11003 if (super_type
&& super_type
->f2k_derived
)
11005 gfc_symtree
* overridden
;
11006 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11007 stree
->name
, true, NULL
);
11009 if (overridden
&& overridden
->n
.tb
)
11010 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11013 stree
->n
.tb
->overridden
= NULL
;
11015 /* Resolve basically using worker function. */
11016 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11020 /* Check the targets to be functions of correct interface. */
11021 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11023 gfc_symbol
* target_proc
;
11025 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11029 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11036 resolve_bindings_result
= FAILURE
;
11037 stree
->n
.tb
->error
= 1;
11041 /* Resolve the type-bound procedures for a derived type. */
11044 resolve_typebound_procedure (gfc_symtree
* stree
)
11048 gfc_symbol
* me_arg
;
11049 gfc_symbol
* super_type
;
11050 gfc_component
* comp
;
11052 gcc_assert (stree
);
11054 /* Undefined specific symbol from GENERIC target definition. */
11058 if (stree
->n
.tb
->error
)
11061 /* If this is a GENERIC binding, use that routine. */
11062 if (stree
->n
.tb
->is_generic
)
11064 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11070 /* Get the target-procedure to check it. */
11071 gcc_assert (!stree
->n
.tb
->is_generic
);
11072 gcc_assert (stree
->n
.tb
->u
.specific
);
11073 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11074 where
= stree
->n
.tb
->where
;
11076 /* Default access should already be resolved from the parser. */
11077 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11079 /* It should be a module procedure or an external procedure with explicit
11080 interface. For DEFERRED bindings, abstract interfaces are ok as well. */
11081 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11082 || (proc
->attr
.proc
!= PROC_MODULE
11083 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11084 || (proc
->attr
.abstract
&& !stree
->n
.tb
->deferred
))
11086 gfc_error ("'%s' must be a module procedure or an external procedure with"
11087 " an explicit interface at %L", proc
->name
, &where
);
11090 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11091 stree
->n
.tb
->function
= proc
->attr
.function
;
11093 /* Find the super-type of the current derived type. We could do this once and
11094 store in a global if speed is needed, but as long as not I believe this is
11095 more readable and clearer. */
11096 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11098 /* If PASS, resolve and check arguments if not already resolved / loaded
11099 from a .mod file. */
11100 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11102 if (stree
->n
.tb
->pass_arg
)
11104 gfc_formal_arglist
* i
;
11106 /* If an explicit passing argument name is given, walk the arg-list
11107 and look for it. */
11110 stree
->n
.tb
->pass_arg_num
= 1;
11111 for (i
= proc
->formal
; i
; i
= i
->next
)
11113 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11118 ++stree
->n
.tb
->pass_arg_num
;
11123 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11125 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11126 stree
->n
.tb
->pass_arg
);
11132 /* Otherwise, take the first one; there should in fact be at least
11134 stree
->n
.tb
->pass_arg_num
= 1;
11137 gfc_error ("Procedure '%s' with PASS at %L must have at"
11138 " least one argument", proc
->name
, &where
);
11141 me_arg
= proc
->formal
->sym
;
11144 /* Now check that the argument-type matches and the passed-object
11145 dummy argument is generally fine. */
11147 gcc_assert (me_arg
);
11149 if (me_arg
->ts
.type
!= BT_CLASS
)
11151 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11152 " at %L", proc
->name
, &where
);
11156 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11157 != resolve_bindings_derived
)
11159 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11160 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11161 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11165 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11166 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
> 0)
11168 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11169 " scalar", proc
->name
, &where
);
11172 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11174 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11175 " be ALLOCATABLE", proc
->name
, &where
);
11178 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11180 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11181 " be POINTER", proc
->name
, &where
);
11186 /* If we are extending some type, check that we don't override a procedure
11187 flagged NON_OVERRIDABLE. */
11188 stree
->n
.tb
->overridden
= NULL
;
11191 gfc_symtree
* overridden
;
11192 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11193 stree
->name
, true, NULL
);
11195 if (overridden
&& overridden
->n
.tb
)
11196 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11198 if (overridden
&& check_typebound_override (stree
, overridden
) == FAILURE
)
11202 /* See if there's a name collision with a component directly in this type. */
11203 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11204 if (!strcmp (comp
->name
, stree
->name
))
11206 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11208 stree
->name
, &where
, resolve_bindings_derived
->name
);
11212 /* Try to find a name collision with an inherited component. */
11213 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11215 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11216 " component of '%s'",
11217 stree
->name
, &where
, resolve_bindings_derived
->name
);
11221 stree
->n
.tb
->error
= 0;
11225 resolve_bindings_result
= FAILURE
;
11226 stree
->n
.tb
->error
= 1;
11231 resolve_typebound_procedures (gfc_symbol
* derived
)
11235 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11238 resolve_bindings_derived
= derived
;
11239 resolve_bindings_result
= SUCCESS
;
11241 /* Make sure the vtab has been generated. */
11242 gfc_find_derived_vtab (derived
);
11244 if (derived
->f2k_derived
->tb_sym_root
)
11245 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11246 &resolve_typebound_procedure
);
11248 if (derived
->f2k_derived
->tb_uop_root
)
11249 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11250 &resolve_typebound_user_op
);
11252 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11254 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11255 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11257 resolve_bindings_result
= FAILURE
;
11260 return resolve_bindings_result
;
11264 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11265 to give all identical derived types the same backend_decl. */
11267 add_dt_to_dt_list (gfc_symbol
*derived
)
11269 gfc_dt_list
*dt_list
;
11271 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11272 if (derived
== dt_list
->derived
)
11275 dt_list
= gfc_get_dt_list ();
11276 dt_list
->next
= gfc_derived_types
;
11277 dt_list
->derived
= derived
;
11278 gfc_derived_types
= dt_list
;
11282 /* Ensure that a derived-type is really not abstract, meaning that every
11283 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11286 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11291 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11293 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11296 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11298 gfc_symtree
* overriding
;
11299 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11302 gcc_assert (overriding
->n
.tb
);
11303 if (overriding
->n
.tb
->deferred
)
11305 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11306 " '%s' is DEFERRED and not overridden",
11307 sub
->name
, &sub
->declared_at
, st
->name
);
11316 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11318 /* The algorithm used here is to recursively travel up the ancestry of sub
11319 and for each ancestor-type, check all bindings. If any of them is
11320 DEFERRED, look it up starting from sub and see if the found (overriding)
11321 binding is not DEFERRED.
11322 This is not the most efficient way to do this, but it should be ok and is
11323 clearer than something sophisticated. */
11325 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11327 if (!ancestor
->attr
.abstract
)
11330 /* Walk bindings of this ancestor. */
11331 if (ancestor
->f2k_derived
)
11334 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11339 /* Find next ancestor type and recurse on it. */
11340 ancestor
= gfc_get_derived_super_type (ancestor
);
11342 return ensure_not_abstract (sub
, ancestor
);
11348 /* Resolve the components of a derived type. */
11351 resolve_fl_derived (gfc_symbol
*sym
)
11353 gfc_symbol
* super_type
;
11356 super_type
= gfc_get_derived_super_type (sym
);
11358 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
11360 /* Fix up incomplete CLASS symbols. */
11361 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
11362 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
11363 if (vptr
->ts
.u
.derived
== NULL
)
11365 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
11367 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
11372 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11374 gfc_error ("As extending type '%s' at %L has a coarray component, "
11375 "parent type '%s' shall also have one", sym
->name
,
11376 &sym
->declared_at
, super_type
->name
);
11380 /* Ensure the extended type gets resolved before we do. */
11381 if (super_type
&& resolve_fl_derived (super_type
) == FAILURE
)
11384 /* An ABSTRACT type must be extensible. */
11385 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11387 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11388 sym
->name
, &sym
->declared_at
);
11392 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
11395 if (c
->attr
.codimension
/* FIXME: c->as check due to PR 43412. */
11396 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11398 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11399 "deferred shape", c
->name
, &c
->loc
);
11404 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11405 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11407 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11408 "shall not be a coarray", c
->name
, &c
->loc
);
11413 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11414 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11415 || c
->attr
.allocatable
))
11417 gfc_error ("Component '%s' at %L with coarray component "
11418 "shall be a nonpointer, nonallocatable scalar",
11424 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11426 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11427 "is not an array pointer", c
->name
, &c
->loc
);
11431 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11433 if (c
->ts
.interface
->attr
.procedure
&& !sym
->attr
.vtype
)
11434 gfc_error ("Interface '%s', used by procedure pointer component "
11435 "'%s' at %L, is declared in a later PROCEDURE statement",
11436 c
->ts
.interface
->name
, c
->name
, &c
->loc
);
11438 /* Get the attributes from the interface (now resolved). */
11439 if (c
->ts
.interface
->attr
.if_source
11440 || c
->ts
.interface
->attr
.intrinsic
)
11442 gfc_symbol
*ifc
= c
->ts
.interface
;
11444 if (ifc
->formal
&& !ifc
->formal_ns
)
11445 resolve_symbol (ifc
);
11447 if (ifc
->attr
.intrinsic
)
11448 resolve_intrinsic (ifc
, &ifc
->declared_at
);
11452 c
->ts
= ifc
->result
->ts
;
11453 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11454 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11455 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
11456 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
11461 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
11462 c
->attr
.pointer
= ifc
->attr
.pointer
;
11463 c
->attr
.dimension
= ifc
->attr
.dimension
;
11464 c
->as
= gfc_copy_array_spec (ifc
->as
);
11466 c
->ts
.interface
= ifc
;
11467 c
->attr
.function
= ifc
->attr
.function
;
11468 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
11469 gfc_copy_formal_args_ppc (c
, ifc
);
11471 c
->attr
.pure
= ifc
->attr
.pure
;
11472 c
->attr
.elemental
= ifc
->attr
.elemental
;
11473 c
->attr
.recursive
= ifc
->attr
.recursive
;
11474 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
11475 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
11476 /* Replace symbols in array spec. */
11480 for (i
= 0; i
< c
->as
->rank
; i
++)
11482 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
11483 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
11486 /* Copy char length. */
11487 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
11489 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
11490 gfc_expr_replace_comp (cl
->length
, c
);
11491 if (cl
->length
&& !cl
->resolved
11492 && gfc_resolve_expr (cl
->length
) == FAILURE
)
11497 else if (!sym
->attr
.vtype
&& c
->ts
.interface
->name
[0] != '\0')
11499 gfc_error ("Interface '%s' of procedure pointer component "
11500 "'%s' at %L must be explicit", c
->ts
.interface
->name
,
11505 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
11507 /* Since PPCs are not implicitly typed, a PPC without an explicit
11508 interface must be a subroutine. */
11509 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
11512 /* Procedure pointer components: Check PASS arg. */
11513 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
11514 && !sym
->attr
.vtype
)
11516 gfc_symbol
* me_arg
;
11518 if (c
->tb
->pass_arg
)
11520 gfc_formal_arglist
* i
;
11522 /* If an explicit passing argument name is given, walk the arg-list
11523 and look for it. */
11526 c
->tb
->pass_arg_num
= 1;
11527 for (i
= c
->formal
; i
; i
= i
->next
)
11529 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
11534 c
->tb
->pass_arg_num
++;
11539 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
11540 "at %L has no argument '%s'", c
->name
,
11541 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
11548 /* Otherwise, take the first one; there should in fact be at least
11550 c
->tb
->pass_arg_num
= 1;
11553 gfc_error ("Procedure pointer component '%s' with PASS at %L "
11554 "must have at least one argument",
11559 me_arg
= c
->formal
->sym
;
11562 /* Now check that the argument-type matches. */
11563 gcc_assert (me_arg
);
11564 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
11565 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
11566 || (me_arg
->ts
.type
== BT_CLASS
11567 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
11569 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11570 " the derived type '%s'", me_arg
->name
, c
->name
,
11571 me_arg
->name
, &c
->loc
, sym
->name
);
11576 /* Check for C453. */
11577 if (me_arg
->attr
.dimension
)
11579 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11580 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
11586 if (me_arg
->attr
.pointer
)
11588 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11589 "may not have the POINTER attribute", me_arg
->name
,
11590 c
->name
, me_arg
->name
, &c
->loc
);
11595 if (me_arg
->attr
.allocatable
)
11597 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
11598 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
11599 me_arg
->name
, &c
->loc
);
11604 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
11605 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11606 " at %L", c
->name
, &c
->loc
);
11610 /* Check type-spec if this is not the parent-type component. */
11611 if ((!sym
->attr
.extension
|| c
!= sym
->components
) && !sym
->attr
.vtype
11612 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
11615 /* If this type is an extension, set the accessibility of the parent
11617 if (super_type
&& c
== sym
->components
11618 && strcmp (super_type
->name
, c
->name
) == 0)
11619 c
->attr
.access
= super_type
->attr
.access
;
11621 /* If this type is an extension, see if this component has the same name
11622 as an inherited type-bound procedure. */
11623 if (super_type
&& !sym
->attr
.is_class
11624 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
11626 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
11627 " inherited type-bound procedure",
11628 c
->name
, sym
->name
, &c
->loc
);
11632 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
11633 && !c
->ts
.deferred
)
11635 if (c
->ts
.u
.cl
->length
== NULL
11636 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
11637 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
11639 gfc_error ("Character length of component '%s' needs to "
11640 "be a constant specification expression at %L",
11642 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
11647 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
11648 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
11650 gfc_error ("Character component '%s' of '%s' at %L with deferred "
11651 "length must be a POINTER or ALLOCATABLE",
11652 c
->name
, sym
->name
, &c
->loc
);
11656 if (c
->ts
.type
== BT_DERIVED
11657 && sym
->component_access
!= ACCESS_PRIVATE
11658 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
11659 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
11660 && !c
->ts
.u
.derived
->attr
.use_assoc
11661 && !gfc_check_access (c
->ts
.u
.derived
->attr
.access
,
11662 c
->ts
.u
.derived
->ns
->default_access
)
11663 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: the component '%s' "
11664 "is a PRIVATE type and cannot be a component of "
11665 "'%s', which is PUBLIC at %L", c
->name
,
11666 sym
->name
, &sym
->declared_at
) == FAILURE
)
11669 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
11671 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
11672 "type %s", c
->name
, &c
->loc
, sym
->name
);
11676 if (sym
->attr
.sequence
)
11678 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
11680 gfc_error ("Component %s of SEQUENCE type declared at %L does "
11681 "not have the SEQUENCE attribute",
11682 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
11687 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
11688 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
11689 && !c
->ts
.u
.derived
->attr
.zero_comp
)
11691 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11692 "that has not been declared", c
->name
, sym
->name
,
11697 if (c
->ts
.type
== BT_CLASS
&& CLASS_DATA (c
)->attr
.class_pointer
11698 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
11699 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
11701 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
11702 "that has not been declared", c
->name
, sym
->name
,
11708 if (c
->ts
.type
== BT_CLASS
11709 && !(CLASS_DATA (c
)->attr
.class_pointer
11710 || CLASS_DATA (c
)->attr
.allocatable
))
11712 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
11713 "or pointer", c
->name
, &c
->loc
);
11717 /* Ensure that all the derived type components are put on the
11718 derived type list; even in formal namespaces, where derived type
11719 pointer components might not have been declared. */
11720 if (c
->ts
.type
== BT_DERIVED
11722 && c
->ts
.u
.derived
->components
11724 && sym
!= c
->ts
.u
.derived
)
11725 add_dt_to_dt_list (c
->ts
.u
.derived
);
11727 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
11728 || c
->attr
.proc_pointer
11729 || c
->attr
.allocatable
)) == FAILURE
)
11733 /* Resolve the type-bound procedures. */
11734 if (resolve_typebound_procedures (sym
) == FAILURE
)
11737 /* Resolve the finalizer procedures. */
11738 if (gfc_resolve_finalizers (sym
) == FAILURE
)
11741 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
11742 all DEFERRED bindings are overridden. */
11743 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
11744 && !sym
->attr
.is_class
11745 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
11748 /* Add derived type to the derived type list. */
11749 add_dt_to_dt_list (sym
);
11756 resolve_fl_namelist (gfc_symbol
*sym
)
11761 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11763 /* Check again, the check in match only works if NAMELIST comes
11765 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
11767 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
11768 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11772 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
11773 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11774 "object '%s' with assumed shape in namelist "
11775 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11776 &sym
->declared_at
) == FAILURE
)
11779 if (is_non_constant_shape_array (nl
->sym
)
11780 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST array "
11781 "object '%s' with nonconstant shape in namelist "
11782 "'%s' at %L", nl
->sym
->name
, sym
->name
,
11783 &sym
->declared_at
) == FAILURE
)
11786 if (nl
->sym
->ts
.type
== BT_CHARACTER
11787 && (nl
->sym
->ts
.u
.cl
->length
== NULL
11788 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
11789 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11790 "'%s' with nonconstant character length in "
11791 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
11792 &sym
->declared_at
) == FAILURE
)
11795 /* FIXME: Once UDDTIO is implemented, the following can be
11797 if (nl
->sym
->ts
.type
== BT_CLASS
)
11799 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
11800 "polymorphic and requires a defined input/output "
11801 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11805 if (nl
->sym
->ts
.type
== BT_DERIVED
11806 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
11807 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
11809 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: NAMELIST object "
11810 "'%s' in namelist '%s' at %L with ALLOCATABLE "
11811 "or POINTER components", nl
->sym
->name
,
11812 sym
->name
, &sym
->declared_at
) == FAILURE
)
11815 /* FIXME: Once UDDTIO is implemented, the following can be
11817 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
11818 "ALLOCATABLE or POINTER components and thus requires "
11819 "a defined input/output procedure", nl
->sym
->name
,
11820 sym
->name
, &sym
->declared_at
);
11825 /* Reject PRIVATE objects in a PUBLIC namelist. */
11826 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
11828 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11830 if (!nl
->sym
->attr
.use_assoc
11831 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
11832 && !gfc_check_access(nl
->sym
->attr
.access
,
11833 nl
->sym
->ns
->default_access
))
11835 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
11836 "cannot be member of PUBLIC namelist '%s' at %L",
11837 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11841 /* Types with private components that came here by USE-association. */
11842 if (nl
->sym
->ts
.type
== BT_DERIVED
11843 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
11845 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
11846 "components and cannot be member of namelist '%s' at %L",
11847 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11851 /* Types with private components that are defined in the same module. */
11852 if (nl
->sym
->ts
.type
== BT_DERIVED
11853 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
11854 && !gfc_check_access (nl
->sym
->ts
.u
.derived
->attr
.private_comp
11855 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
11856 nl
->sym
->ns
->default_access
))
11858 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
11859 "cannot be a member of PUBLIC namelist '%s' at %L",
11860 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
11867 /* 14.1.2 A module or internal procedure represent local entities
11868 of the same type as a namelist member and so are not allowed. */
11869 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
11871 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
11874 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
11875 if ((nl
->sym
== sym
->ns
->proc_name
)
11877 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
11881 if (nl
->sym
&& nl
->sym
->name
)
11882 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
11883 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
11885 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
11886 "attribute in '%s' at %L", nlsym
->name
,
11887 &sym
->declared_at
);
11897 resolve_fl_parameter (gfc_symbol
*sym
)
11899 /* A parameter array's shape needs to be constant. */
11900 if (sym
->as
!= NULL
11901 && (sym
->as
->type
== AS_DEFERRED
11902 || is_non_constant_shape_array (sym
)))
11904 gfc_error ("Parameter array '%s' at %L cannot be automatic "
11905 "or of deferred shape", sym
->name
, &sym
->declared_at
);
11909 /* Make sure a parameter that has been implicitly typed still
11910 matches the implicit type, since PARAMETER statements can precede
11911 IMPLICIT statements. */
11912 if (sym
->attr
.implicit_type
11913 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
11916 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
11917 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
11921 /* Make sure the types of derived parameters are consistent. This
11922 type checking is deferred until resolution because the type may
11923 refer to a derived type from the host. */
11924 if (sym
->ts
.type
== BT_DERIVED
11925 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
11927 gfc_error ("Incompatible derived type in PARAMETER at %L",
11928 &sym
->value
->where
);
11935 /* Do anything necessary to resolve a symbol. Right now, we just
11936 assume that an otherwise unknown symbol is a variable. This sort
11937 of thing commonly happens for symbols in module. */
11940 resolve_symbol (gfc_symbol
*sym
)
11942 int check_constant
, mp_flag
;
11943 gfc_symtree
*symtree
;
11944 gfc_symtree
*this_symtree
;
11948 /* Avoid double resolution of function result symbols. */
11949 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
11950 && (sym
->ns
!= gfc_current_ns
))
11953 if (sym
->attr
.flavor
== FL_UNKNOWN
)
11956 /* If we find that a flavorless symbol is an interface in one of the
11957 parent namespaces, find its symtree in this namespace, free the
11958 symbol and set the symtree to point to the interface symbol. */
11959 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
11961 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
11962 if (symtree
&& (symtree
->n
.sym
->generic
||
11963 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
11964 && sym
->ns
->construct_entities
)))
11966 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
11968 gfc_release_symbol (sym
);
11969 symtree
->n
.sym
->refs
++;
11970 this_symtree
->n
.sym
= symtree
->n
.sym
;
11975 /* Otherwise give it a flavor according to such attributes as
11977 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
11978 sym
->attr
.flavor
= FL_VARIABLE
;
11981 sym
->attr
.flavor
= FL_PROCEDURE
;
11982 if (sym
->attr
.dimension
)
11983 sym
->attr
.function
= 1;
11987 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
11988 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
11990 if (sym
->attr
.procedure
&& sym
->ts
.interface
11991 && sym
->attr
.if_source
!= IFSRC_DECL
11992 && resolve_procedure_interface (sym
) == FAILURE
)
11995 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
11996 && (sym
->attr
.procedure
|| sym
->attr
.external
))
11998 if (sym
->attr
.external
)
11999 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12000 "at %L", &sym
->declared_at
);
12002 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12003 "at %L", &sym
->declared_at
);
12010 if (sym
->attr
.contiguous
12011 && (!sym
->attr
.dimension
|| (sym
->as
->type
!= AS_ASSUMED_SHAPE
12012 && !sym
->attr
.pointer
)))
12014 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12015 "array pointer or an assumed-shape array", sym
->name
,
12016 &sym
->declared_at
);
12020 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12023 /* Symbols that are module procedures with results (functions) have
12024 the types and array specification copied for type checking in
12025 procedures that call them, as well as for saving to a module
12026 file. These symbols can't stand the scrutiny that their results
12028 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12030 /* Make sure that the intrinsic is consistent with its internal
12031 representation. This needs to be done before assigning a default
12032 type to avoid spurious warnings. */
12033 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12034 && resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12037 /* Resolve associate names. */
12039 resolve_assoc_var (sym
, true);
12041 /* Assign default type to symbols that need one and don't have one. */
12042 if (sym
->ts
.type
== BT_UNKNOWN
)
12044 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12045 gfc_set_default_type (sym
, 1, NULL
);
12047 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12048 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12049 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12050 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12052 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12054 /* The specific case of an external procedure should emit an error
12055 in the case that there is no implicit type. */
12057 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12060 /* Result may be in another namespace. */
12061 resolve_symbol (sym
->result
);
12063 if (!sym
->result
->attr
.proc_pointer
)
12065 sym
->ts
= sym
->result
->ts
;
12066 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12067 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12068 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12069 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12070 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12076 /* Assumed size arrays and assumed shape arrays must be dummy
12077 arguments. Array-spec's of implied-shape should have been resolved to
12078 AS_EXPLICIT already. */
12082 gcc_assert (sym
->as
->type
!= AS_IMPLIED_SHAPE
);
12083 if (((sym
->as
->type
== AS_ASSUMED_SIZE
&& !sym
->as
->cp_was_assumed
)
12084 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
12085 && sym
->attr
.dummy
== 0)
12087 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
12088 gfc_error ("Assumed size array at %L must be a dummy argument",
12089 &sym
->declared_at
);
12091 gfc_error ("Assumed shape array at %L must be a dummy argument",
12092 &sym
->declared_at
);
12097 /* Make sure symbols with known intent or optional are really dummy
12098 variable. Because of ENTRY statement, this has to be deferred
12099 until resolution time. */
12101 if (!sym
->attr
.dummy
12102 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12104 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12108 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12110 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12111 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12115 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12117 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12118 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12120 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12121 "attribute must have constant length",
12122 sym
->name
, &sym
->declared_at
);
12126 if (sym
->ts
.is_c_interop
12127 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12129 gfc_error ("C interoperable character dummy variable '%s' at %L "
12130 "with VALUE attribute must have length one",
12131 sym
->name
, &sym
->declared_at
);
12136 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12137 do this for something that was implicitly typed because that is handled
12138 in gfc_set_default_type. Handle dummy arguments and procedure
12139 definitions separately. Also, anything that is use associated is not
12140 handled here but instead is handled in the module it is declared in.
12141 Finally, derived type definitions are allowed to be BIND(C) since that
12142 only implies that they're interoperable, and they are checked fully for
12143 interoperability when a variable is declared of that type. */
12144 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12145 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12146 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12148 gfc_try t
= SUCCESS
;
12150 /* First, make sure the variable is declared at the
12151 module-level scope (J3/04-007, Section 15.3). */
12152 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12153 sym
->attr
.in_common
== 0)
12155 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12156 "is neither a COMMON block nor declared at the "
12157 "module level scope", sym
->name
, &(sym
->declared_at
));
12160 else if (sym
->common_head
!= NULL
)
12162 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12166 /* If type() declaration, we need to verify that the components
12167 of the given type are all C interoperable, etc. */
12168 if (sym
->ts
.type
== BT_DERIVED
&&
12169 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12171 /* Make sure the user marked the derived type as BIND(C). If
12172 not, call the verify routine. This could print an error
12173 for the derived type more than once if multiple variables
12174 of that type are declared. */
12175 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12176 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12180 /* Verify the variable itself as C interoperable if it
12181 is BIND(C). It is not possible for this to succeed if
12182 the verify_bind_c_derived_type failed, so don't have to handle
12183 any error returned by verify_bind_c_derived_type. */
12184 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12185 sym
->common_block
);
12190 /* clear the is_bind_c flag to prevent reporting errors more than
12191 once if something failed. */
12192 sym
->attr
.is_bind_c
= 0;
12197 /* If a derived type symbol has reached this point, without its
12198 type being declared, we have an error. Notice that most
12199 conditions that produce undefined derived types have already
12200 been dealt with. However, the likes of:
12201 implicit type(t) (t) ..... call foo (t) will get us here if
12202 the type is not declared in the scope of the implicit
12203 statement. Change the type to BT_UNKNOWN, both because it is so
12204 and to prevent an ICE. */
12205 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->components
== NULL
12206 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12208 gfc_error ("The derived type '%s' at %L is of type '%s', "
12209 "which has not been defined", sym
->name
,
12210 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12211 sym
->ts
.type
= BT_UNKNOWN
;
12215 /* Make sure that the derived type has been resolved and that the
12216 derived type is visible in the symbol's namespace, if it is a
12217 module function and is not PRIVATE. */
12218 if (sym
->ts
.type
== BT_DERIVED
12219 && sym
->ts
.u
.derived
->attr
.use_assoc
12220 && sym
->ns
->proc_name
12221 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
12225 if (resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12228 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 1, &ds
);
12229 if (!ds
&& sym
->attr
.function
12230 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
12232 symtree
= gfc_new_symtree (&sym
->ns
->sym_root
,
12233 sym
->ts
.u
.derived
->name
);
12234 symtree
->n
.sym
= sym
->ts
.u
.derived
;
12235 sym
->ts
.u
.derived
->refs
++;
12239 /* Unless the derived-type declaration is use associated, Fortran 95
12240 does not allow public entries of private derived types.
12241 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12242 161 in 95-006r3. */
12243 if (sym
->ts
.type
== BT_DERIVED
12244 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12245 && !sym
->ts
.u
.derived
->attr
.use_assoc
12246 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
12247 && !gfc_check_access (sym
->ts
.u
.derived
->attr
.access
,
12248 sym
->ts
.u
.derived
->ns
->default_access
)
12249 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
12250 "of PRIVATE derived type '%s'",
12251 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12252 : "variable", sym
->name
, &sym
->declared_at
,
12253 sym
->ts
.u
.derived
->name
) == FAILURE
)
12256 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12257 default initialization is defined (5.1.2.4.4). */
12258 if (sym
->ts
.type
== BT_DERIVED
12260 && sym
->attr
.intent
== INTENT_OUT
12262 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12264 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12266 if (c
->initializer
)
12268 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12269 "ASSUMED SIZE and so cannot have a default initializer",
12270 sym
->name
, &sym
->declared_at
);
12277 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12278 || sym
->attr
.codimension
)
12279 && sym
->attr
.result
)
12280 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12281 "a coarray component", sym
->name
, &sym
->declared_at
);
12284 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12285 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12286 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12287 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12290 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
12291 && (sym
->attr
.codimension
|| sym
->attr
.pointer
|| sym
->attr
.dimension
12292 || sym
->attr
.allocatable
))
12293 gfc_error ("Variable '%s' at %L with coarray component "
12294 "shall be a nonpointer, nonallocatable scalar",
12295 sym
->name
, &sym
->declared_at
);
12297 /* F2008, C526. The function-result case was handled above. */
12298 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12299 || sym
->attr
.codimension
)
12300 && !(sym
->attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12301 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12302 || sym
->ns
->proc_name
->attr
.is_main_program
12303 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
12304 gfc_error ("Variable '%s' at %L is a coarray or has a coarray "
12305 "component and is not ALLOCATABLE, SAVE nor a "
12306 "dummy argument", sym
->name
, &sym
->declared_at
);
12307 /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */
12308 else if (sym
->attr
.codimension
&& !sym
->attr
.allocatable
12309 && sym
->as
&& sym
->as
->cotype
== AS_DEFERRED
)
12310 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
12311 "deferred shape", sym
->name
, &sym
->declared_at
);
12312 else if (sym
->attr
.codimension
&& sym
->attr
.allocatable
12313 && (sym
->as
->type
!= AS_DEFERRED
|| sym
->as
->cotype
!= AS_DEFERRED
))
12314 gfc_error ("Allocatable coarray variable '%s' at %L must have "
12315 "deferred shape", sym
->name
, &sym
->declared_at
);
12319 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12320 || (sym
->attr
.codimension
&& sym
->attr
.allocatable
))
12321 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
12322 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
12323 "allocatable coarray or have coarray components",
12324 sym
->name
, &sym
->declared_at
);
12326 if (sym
->attr
.codimension
&& sym
->attr
.dummy
12327 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
12328 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
12329 "procedure '%s'", sym
->name
, &sym
->declared_at
,
12330 sym
->ns
->proc_name
->name
);
12332 switch (sym
->attr
.flavor
)
12335 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
12340 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
12345 if (resolve_fl_namelist (sym
) == FAILURE
)
12350 if (resolve_fl_parameter (sym
) == FAILURE
)
12358 /* Resolve array specifier. Check as well some constraints
12359 on COMMON blocks. */
12361 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
12363 /* Set the formal_arg_flag so that check_conflict will not throw
12364 an error for host associated variables in the specification
12365 expression for an array_valued function. */
12366 if (sym
->attr
.function
&& sym
->as
)
12367 formal_arg_flag
= 1;
12369 gfc_resolve_array_spec (sym
->as
, check_constant
);
12371 formal_arg_flag
= 0;
12373 /* Resolve formal namespaces. */
12374 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
12375 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
12376 gfc_resolve (sym
->formal_ns
);
12378 /* Make sure the formal namespace is present. */
12379 if (sym
->formal
&& !sym
->formal_ns
)
12381 gfc_formal_arglist
*formal
= sym
->formal
;
12382 while (formal
&& !formal
->sym
)
12383 formal
= formal
->next
;
12387 sym
->formal_ns
= formal
->sym
->ns
;
12388 sym
->formal_ns
->refs
++;
12392 /* Check threadprivate restrictions. */
12393 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
12394 && (!sym
->attr
.in_common
12395 && sym
->module
== NULL
12396 && (sym
->ns
->proc_name
== NULL
12397 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
12398 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
12400 /* If we have come this far we can apply default-initializers, as
12401 described in 14.7.5, to those variables that have not already
12402 been assigned one. */
12403 if (sym
->ts
.type
== BT_DERIVED
12404 && sym
->ns
== gfc_current_ns
12406 && !sym
->attr
.allocatable
12407 && !sym
->attr
.alloc_comp
)
12409 symbol_attribute
*a
= &sym
->attr
;
12411 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
12412 && !a
->in_common
&& !a
->use_assoc
12413 && (a
->referenced
|| a
->result
)
12414 && !(a
->function
&& sym
!= sym
->result
))
12415 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
12416 apply_default_init (sym
);
12419 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
12420 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
12421 && !CLASS_DATA (sym
)->attr
.class_pointer
12422 && !CLASS_DATA (sym
)->attr
.allocatable
)
12423 apply_default_init (sym
);
12425 /* If this symbol has a type-spec, check it. */
12426 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
12427 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
12428 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
12434 /************* Resolve DATA statements *************/
12438 gfc_data_value
*vnode
;
12444 /* Advance the values structure to point to the next value in the data list. */
12447 next_data_value (void)
12449 while (mpz_cmp_ui (values
.left
, 0) == 0)
12452 if (values
.vnode
->next
== NULL
)
12455 values
.vnode
= values
.vnode
->next
;
12456 mpz_set (values
.left
, values
.vnode
->repeat
);
12464 check_data_variable (gfc_data_variable
*var
, locus
*where
)
12470 ar_type mark
= AR_UNKNOWN
;
12472 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
12478 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
12482 mpz_init_set_si (offset
, 0);
12485 if (e
->expr_type
!= EXPR_VARIABLE
)
12486 gfc_internal_error ("check_data_variable(): Bad expression");
12488 sym
= e
->symtree
->n
.sym
;
12490 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
12492 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
12493 sym
->name
, &sym
->declared_at
);
12496 if (e
->ref
== NULL
&& sym
->as
)
12498 gfc_error ("DATA array '%s' at %L must be specified in a previous"
12499 " declaration", sym
->name
, where
);
12503 has_pointer
= sym
->attr
.pointer
;
12505 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12507 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
12510 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
)
12512 gfc_error ("DATA element '%s' at %L cannot have a coindex",
12518 && ref
->type
== REF_ARRAY
12519 && ref
->u
.ar
.type
!= AR_FULL
)
12521 gfc_error ("DATA element '%s' at %L is a pointer and so must "
12522 "be a full array", sym
->name
, where
);
12527 if (e
->rank
== 0 || has_pointer
)
12529 mpz_init_set_ui (size
, 1);
12536 /* Find the array section reference. */
12537 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
12539 if (ref
->type
!= REF_ARRAY
)
12541 if (ref
->u
.ar
.type
== AR_ELEMENT
)
12547 /* Set marks according to the reference pattern. */
12548 switch (ref
->u
.ar
.type
)
12556 /* Get the start position of array section. */
12557 gfc_get_section_index (ar
, section_index
, &offset
);
12562 gcc_unreachable ();
12565 if (gfc_array_size (e
, &size
) == FAILURE
)
12567 gfc_error ("Nonconstant array section at %L in DATA statement",
12569 mpz_clear (offset
);
12576 while (mpz_cmp_ui (size
, 0) > 0)
12578 if (next_data_value () == FAILURE
)
12580 gfc_error ("DATA statement at %L has more variables than values",
12586 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
12590 /* If we have more than one element left in the repeat count,
12591 and we have more than one element left in the target variable,
12592 then create a range assignment. */
12593 /* FIXME: Only done for full arrays for now, since array sections
12595 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
12596 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
12600 if (mpz_cmp (size
, values
.left
) >= 0)
12602 mpz_init_set (range
, values
.left
);
12603 mpz_sub (size
, size
, values
.left
);
12604 mpz_set_ui (values
.left
, 0);
12608 mpz_init_set (range
, size
);
12609 mpz_sub (values
.left
, values
.left
, size
);
12610 mpz_set_ui (size
, 0);
12613 t
= gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
12616 mpz_add (offset
, offset
, range
);
12623 /* Assign initial value to symbol. */
12626 mpz_sub_ui (values
.left
, values
.left
, 1);
12627 mpz_sub_ui (size
, size
, 1);
12629 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
12633 if (mark
== AR_FULL
)
12634 mpz_add_ui (offset
, offset
, 1);
12636 /* Modify the array section indexes and recalculate the offset
12637 for next element. */
12638 else if (mark
== AR_SECTION
)
12639 gfc_advance_section (section_index
, ar
, &offset
);
12643 if (mark
== AR_SECTION
)
12645 for (i
= 0; i
< ar
->dimen
; i
++)
12646 mpz_clear (section_index
[i
]);
12650 mpz_clear (offset
);
12656 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
12658 /* Iterate over a list of elements in a DATA statement. */
12661 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
12664 iterator_stack frame
;
12665 gfc_expr
*e
, *start
, *end
, *step
;
12666 gfc_try retval
= SUCCESS
;
12668 mpz_init (frame
.value
);
12671 start
= gfc_copy_expr (var
->iter
.start
);
12672 end
= gfc_copy_expr (var
->iter
.end
);
12673 step
= gfc_copy_expr (var
->iter
.step
);
12675 if (gfc_simplify_expr (start
, 1) == FAILURE
12676 || start
->expr_type
!= EXPR_CONSTANT
)
12678 gfc_error ("start of implied-do loop at %L could not be "
12679 "simplified to a constant value", &start
->where
);
12683 if (gfc_simplify_expr (end
, 1) == FAILURE
12684 || end
->expr_type
!= EXPR_CONSTANT
)
12686 gfc_error ("end of implied-do loop at %L could not be "
12687 "simplified to a constant value", &start
->where
);
12691 if (gfc_simplify_expr (step
, 1) == FAILURE
12692 || step
->expr_type
!= EXPR_CONSTANT
)
12694 gfc_error ("step of implied-do loop at %L could not be "
12695 "simplified to a constant value", &start
->where
);
12700 mpz_set (trip
, end
->value
.integer
);
12701 mpz_sub (trip
, trip
, start
->value
.integer
);
12702 mpz_add (trip
, trip
, step
->value
.integer
);
12704 mpz_div (trip
, trip
, step
->value
.integer
);
12706 mpz_set (frame
.value
, start
->value
.integer
);
12708 frame
.prev
= iter_stack
;
12709 frame
.variable
= var
->iter
.var
->symtree
;
12710 iter_stack
= &frame
;
12712 while (mpz_cmp_ui (trip
, 0) > 0)
12714 if (traverse_data_var (var
->list
, where
) == FAILURE
)
12720 e
= gfc_copy_expr (var
->expr
);
12721 if (gfc_simplify_expr (e
, 1) == FAILURE
)
12728 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
12730 mpz_sub_ui (trip
, trip
, 1);
12734 mpz_clear (frame
.value
);
12737 gfc_free_expr (start
);
12738 gfc_free_expr (end
);
12739 gfc_free_expr (step
);
12741 iter_stack
= frame
.prev
;
12746 /* Type resolve variables in the variable list of a DATA statement. */
12749 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
12753 for (; var
; var
= var
->next
)
12755 if (var
->expr
== NULL
)
12756 t
= traverse_data_list (var
, where
);
12758 t
= check_data_variable (var
, where
);
12768 /* Resolve the expressions and iterators associated with a data statement.
12769 This is separate from the assignment checking because data lists should
12770 only be resolved once. */
12773 resolve_data_variables (gfc_data_variable
*d
)
12775 for (; d
; d
= d
->next
)
12777 if (d
->list
== NULL
)
12779 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
12784 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
12787 if (resolve_data_variables (d
->list
) == FAILURE
)
12796 /* Resolve a single DATA statement. We implement this by storing a pointer to
12797 the value list into static variables, and then recursively traversing the
12798 variables list, expanding iterators and such. */
12801 resolve_data (gfc_data
*d
)
12804 if (resolve_data_variables (d
->var
) == FAILURE
)
12807 values
.vnode
= d
->value
;
12808 if (d
->value
== NULL
)
12809 mpz_set_ui (values
.left
, 0);
12811 mpz_set (values
.left
, d
->value
->repeat
);
12813 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
12816 /* At this point, we better not have any values left. */
12818 if (next_data_value () == SUCCESS
)
12819 gfc_error ("DATA statement at %L has more values than variables",
12824 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
12825 accessed by host or use association, is a dummy argument to a pure function,
12826 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
12827 is storage associated with any such variable, shall not be used in the
12828 following contexts: (clients of this function). */
12830 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
12831 procedure. Returns zero if assignment is OK, nonzero if there is a
12834 gfc_impure_variable (gfc_symbol
*sym
)
12839 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
12842 /* Check if the symbol's ns is inside the pure procedure. */
12843 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
12847 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
12851 proc
= sym
->ns
->proc_name
;
12852 if (sym
->attr
.dummy
&& gfc_pure (proc
)
12853 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
12855 proc
->attr
.function
))
12858 /* TODO: Sort out what can be storage associated, if anything, and include
12859 it here. In principle equivalences should be scanned but it does not
12860 seem to be possible to storage associate an impure variable this way. */
12865 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
12866 current namespace is inside a pure procedure. */
12869 gfc_pure (gfc_symbol
*sym
)
12871 symbol_attribute attr
;
12876 /* Check if the current namespace or one of its parents
12877 belongs to a pure procedure. */
12878 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
12880 sym
= ns
->proc_name
;
12884 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
12892 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
12896 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
12897 checks if the current namespace is implicitly pure. Note that this
12898 function returns false for a PURE procedure. */
12901 gfc_implicit_pure (gfc_symbol
*sym
)
12903 symbol_attribute attr
;
12907 /* Check if the current namespace is implicit_pure. */
12908 sym
= gfc_current_ns
->proc_name
;
12912 if (attr
.flavor
== FL_PROCEDURE
12913 && attr
.implicit_pure
&& !attr
.pure
)
12920 return attr
.flavor
== FL_PROCEDURE
&& attr
.implicit_pure
&& !attr
.pure
;
12924 /* Test whether the current procedure is elemental or not. */
12927 gfc_elemental (gfc_symbol
*sym
)
12929 symbol_attribute attr
;
12932 sym
= gfc_current_ns
->proc_name
;
12937 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
12941 /* Warn about unused labels. */
12944 warn_unused_fortran_label (gfc_st_label
*label
)
12949 warn_unused_fortran_label (label
->left
);
12951 if (label
->defined
== ST_LABEL_UNKNOWN
)
12954 switch (label
->referenced
)
12956 case ST_LABEL_UNKNOWN
:
12957 gfc_warning ("Label %d at %L defined but not used", label
->value
,
12961 case ST_LABEL_BAD_TARGET
:
12962 gfc_warning ("Label %d at %L defined but cannot be used",
12963 label
->value
, &label
->where
);
12970 warn_unused_fortran_label (label
->right
);
12974 /* Returns the sequence type of a symbol or sequence. */
12977 sequence_type (gfc_typespec ts
)
12986 if (ts
.u
.derived
->components
== NULL
)
12987 return SEQ_NONDEFAULT
;
12989 result
= sequence_type (ts
.u
.derived
->components
->ts
);
12990 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
12991 if (sequence_type (c
->ts
) != result
)
12997 if (ts
.kind
!= gfc_default_character_kind
)
12998 return SEQ_NONDEFAULT
;
13000 return SEQ_CHARACTER
;
13003 if (ts
.kind
!= gfc_default_integer_kind
)
13004 return SEQ_NONDEFAULT
;
13006 return SEQ_NUMERIC
;
13009 if (!(ts
.kind
== gfc_default_real_kind
13010 || ts
.kind
== gfc_default_double_kind
))
13011 return SEQ_NONDEFAULT
;
13013 return SEQ_NUMERIC
;
13016 if (ts
.kind
!= gfc_default_complex_kind
)
13017 return SEQ_NONDEFAULT
;
13019 return SEQ_NUMERIC
;
13022 if (ts
.kind
!= gfc_default_logical_kind
)
13023 return SEQ_NONDEFAULT
;
13025 return SEQ_NUMERIC
;
13028 return SEQ_NONDEFAULT
;
13033 /* Resolve derived type EQUIVALENCE object. */
13036 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13038 gfc_component
*c
= derived
->components
;
13043 /* Shall not be an object of nonsequence derived type. */
13044 if (!derived
->attr
.sequence
)
13046 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13047 "attribute to be an EQUIVALENCE object", sym
->name
,
13052 /* Shall not have allocatable components. */
13053 if (derived
->attr
.alloc_comp
)
13055 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13056 "components to be an EQUIVALENCE object",sym
->name
,
13061 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13063 gfc_error ("Derived type variable '%s' at %L with default "
13064 "initialization cannot be in EQUIVALENCE with a variable "
13065 "in COMMON", sym
->name
, &e
->where
);
13069 for (; c
; c
= c
->next
)
13071 if (c
->ts
.type
== BT_DERIVED
13072 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13075 /* Shall not be an object of sequence derived type containing a pointer
13076 in the structure. */
13077 if (c
->attr
.pointer
)
13079 gfc_error ("Derived type variable '%s' at %L with pointer "
13080 "component(s) cannot be an EQUIVALENCE object",
13081 sym
->name
, &e
->where
);
13089 /* Resolve equivalence object.
13090 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13091 an allocatable array, an object of nonsequence derived type, an object of
13092 sequence derived type containing a pointer at any level of component
13093 selection, an automatic object, a function name, an entry name, a result
13094 name, a named constant, a structure component, or a subobject of any of
13095 the preceding objects. A substring shall not have length zero. A
13096 derived type shall not have components with default initialization nor
13097 shall two objects of an equivalence group be initialized.
13098 Either all or none of the objects shall have an protected attribute.
13099 The simple constraints are done in symbol.c(check_conflict) and the rest
13100 are implemented here. */
13103 resolve_equivalence (gfc_equiv
*eq
)
13106 gfc_symbol
*first_sym
;
13109 locus
*last_where
= NULL
;
13110 seq_type eq_type
, last_eq_type
;
13111 gfc_typespec
*last_ts
;
13112 int object
, cnt_protected
;
13115 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13117 first_sym
= eq
->expr
->symtree
->n
.sym
;
13121 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13125 e
->ts
= e
->symtree
->n
.sym
->ts
;
13126 /* match_varspec might not know yet if it is seeing
13127 array reference or substring reference, as it doesn't
13129 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13131 gfc_ref
*ref
= e
->ref
;
13132 sym
= e
->symtree
->n
.sym
;
13134 if (sym
->attr
.dimension
)
13136 ref
->u
.ar
.as
= sym
->as
;
13140 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13141 if (e
->ts
.type
== BT_CHARACTER
13143 && ref
->type
== REF_ARRAY
13144 && ref
->u
.ar
.dimen
== 1
13145 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13146 && ref
->u
.ar
.stride
[0] == NULL
)
13148 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13149 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13152 /* Optimize away the (:) reference. */
13153 if (start
== NULL
&& end
== NULL
)
13156 e
->ref
= ref
->next
;
13158 e
->ref
->next
= ref
->next
;
13163 ref
->type
= REF_SUBSTRING
;
13165 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13167 ref
->u
.ss
.start
= start
;
13168 if (end
== NULL
&& e
->ts
.u
.cl
)
13169 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13170 ref
->u
.ss
.end
= end
;
13171 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13178 /* Any further ref is an error. */
13181 gcc_assert (ref
->type
== REF_ARRAY
);
13182 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13188 if (gfc_resolve_expr (e
) == FAILURE
)
13191 sym
= e
->symtree
->n
.sym
;
13193 if (sym
->attr
.is_protected
)
13195 if (cnt_protected
> 0 && cnt_protected
!= object
)
13197 gfc_error ("Either all or none of the objects in the "
13198 "EQUIVALENCE set at %L shall have the "
13199 "PROTECTED attribute",
13204 /* Shall not equivalence common block variables in a PURE procedure. */
13205 if (sym
->ns
->proc_name
13206 && sym
->ns
->proc_name
->attr
.pure
13207 && sym
->attr
.in_common
)
13209 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13210 "object in the pure procedure '%s'",
13211 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13215 /* Shall not be a named constant. */
13216 if (e
->expr_type
== EXPR_CONSTANT
)
13218 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13219 "object", sym
->name
, &e
->where
);
13223 if (e
->ts
.type
== BT_DERIVED
13224 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13227 /* Check that the types correspond correctly:
13229 A numeric sequence structure may be equivalenced to another sequence
13230 structure, an object of default integer type, default real type, double
13231 precision real type, default logical type such that components of the
13232 structure ultimately only become associated to objects of the same
13233 kind. A character sequence structure may be equivalenced to an object
13234 of default character kind or another character sequence structure.
13235 Other objects may be equivalenced only to objects of the same type and
13236 kind parameters. */
13238 /* Identical types are unconditionally OK. */
13239 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13240 goto identical_types
;
13242 last_eq_type
= sequence_type (*last_ts
);
13243 eq_type
= sequence_type (sym
->ts
);
13245 /* Since the pair of objects is not of the same type, mixed or
13246 non-default sequences can be rejected. */
13248 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13249 "statement at %L with different type objects";
13251 && last_eq_type
== SEQ_MIXED
13252 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13254 || (eq_type
== SEQ_MIXED
13255 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13256 &e
->where
) == FAILURE
))
13259 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13260 "statement at %L with objects of different type";
13262 && last_eq_type
== SEQ_NONDEFAULT
13263 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13264 last_where
) == FAILURE
)
13265 || (eq_type
== SEQ_NONDEFAULT
13266 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13267 &e
->where
) == FAILURE
))
13270 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13271 "EQUIVALENCE statement at %L";
13272 if (last_eq_type
== SEQ_CHARACTER
13273 && eq_type
!= SEQ_CHARACTER
13274 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13275 &e
->where
) == FAILURE
)
13278 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13279 "EQUIVALENCE statement at %L";
13280 if (last_eq_type
== SEQ_NUMERIC
13281 && eq_type
!= SEQ_NUMERIC
13282 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13283 &e
->where
) == FAILURE
)
13288 last_where
= &e
->where
;
13293 /* Shall not be an automatic array. */
13294 if (e
->ref
->type
== REF_ARRAY
13295 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
13297 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
13298 "an EQUIVALENCE object", sym
->name
, &e
->where
);
13305 /* Shall not be a structure component. */
13306 if (r
->type
== REF_COMPONENT
)
13308 gfc_error ("Structure component '%s' at %L cannot be an "
13309 "EQUIVALENCE object",
13310 r
->u
.c
.component
->name
, &e
->where
);
13314 /* A substring shall not have length zero. */
13315 if (r
->type
== REF_SUBSTRING
)
13317 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
13319 gfc_error ("Substring at %L has length zero",
13320 &r
->u
.ss
.start
->where
);
13330 /* Resolve function and ENTRY types, issue diagnostics if needed. */
13333 resolve_fntype (gfc_namespace
*ns
)
13335 gfc_entry_list
*el
;
13338 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
13341 /* If there are any entries, ns->proc_name is the entry master
13342 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
13344 sym
= ns
->entries
->sym
;
13346 sym
= ns
->proc_name
;
13347 if (sym
->result
== sym
13348 && sym
->ts
.type
== BT_UNKNOWN
13349 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
13350 && !sym
->attr
.untyped
)
13352 gfc_error ("Function '%s' at %L has no IMPLICIT type",
13353 sym
->name
, &sym
->declared_at
);
13354 sym
->attr
.untyped
= 1;
13357 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
13358 && !sym
->attr
.contained
13359 && !gfc_check_access (sym
->ts
.u
.derived
->attr
.access
,
13360 sym
->ts
.u
.derived
->ns
->default_access
)
13361 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
13363 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
13364 "%L of PRIVATE type '%s'", sym
->name
,
13365 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
13369 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
13371 if (el
->sym
->result
== el
->sym
13372 && el
->sym
->ts
.type
== BT_UNKNOWN
13373 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
13374 && !el
->sym
->attr
.untyped
)
13376 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
13377 el
->sym
->name
, &el
->sym
->declared_at
);
13378 el
->sym
->attr
.untyped
= 1;
13384 /* 12.3.2.1.1 Defined operators. */
13387 check_uop_procedure (gfc_symbol
*sym
, locus where
)
13389 gfc_formal_arglist
*formal
;
13391 if (!sym
->attr
.function
)
13393 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
13394 sym
->name
, &where
);
13398 if (sym
->ts
.type
== BT_CHARACTER
13399 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
13400 && !(sym
->result
&& sym
->result
->ts
.u
.cl
13401 && sym
->result
->ts
.u
.cl
->length
))
13403 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
13404 "character length", sym
->name
, &where
);
13408 formal
= sym
->formal
;
13409 if (!formal
|| !formal
->sym
)
13411 gfc_error ("User operator procedure '%s' at %L must have at least "
13412 "one argument", sym
->name
, &where
);
13416 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13418 gfc_error ("First argument of operator interface at %L must be "
13419 "INTENT(IN)", &where
);
13423 if (formal
->sym
->attr
.optional
)
13425 gfc_error ("First argument of operator interface at %L cannot be "
13426 "optional", &where
);
13430 formal
= formal
->next
;
13431 if (!formal
|| !formal
->sym
)
13434 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
13436 gfc_error ("Second argument of operator interface at %L must be "
13437 "INTENT(IN)", &where
);
13441 if (formal
->sym
->attr
.optional
)
13443 gfc_error ("Second argument of operator interface at %L cannot be "
13444 "optional", &where
);
13450 gfc_error ("Operator interface at %L must have, at most, two "
13451 "arguments", &where
);
13459 gfc_resolve_uops (gfc_symtree
*symtree
)
13461 gfc_interface
*itr
;
13463 if (symtree
== NULL
)
13466 gfc_resolve_uops (symtree
->left
);
13467 gfc_resolve_uops (symtree
->right
);
13469 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
13470 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
13474 /* Examine all of the expressions associated with a program unit,
13475 assign types to all intermediate expressions, make sure that all
13476 assignments are to compatible types and figure out which names
13477 refer to which functions or subroutines. It doesn't check code
13478 block, which is handled by resolve_code. */
13481 resolve_types (gfc_namespace
*ns
)
13487 gfc_namespace
* old_ns
= gfc_current_ns
;
13489 /* Check that all IMPLICIT types are ok. */
13490 if (!ns
->seen_implicit_none
)
13493 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
13494 if (ns
->set_flag
[letter
]
13495 && resolve_typespec_used (&ns
->default_type
[letter
],
13496 &ns
->implicit_loc
[letter
],
13501 gfc_current_ns
= ns
;
13503 resolve_entries (ns
);
13505 resolve_common_vars (ns
->blank_common
.head
, false);
13506 resolve_common_blocks (ns
->common_root
);
13508 resolve_contained_functions (ns
);
13510 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
13512 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
13513 resolve_charlen (cl
);
13515 gfc_traverse_ns (ns
, resolve_symbol
);
13517 resolve_fntype (ns
);
13519 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13521 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
13522 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
13523 "also be PURE", n
->proc_name
->name
,
13524 &n
->proc_name
->declared_at
);
13530 gfc_check_interfaces (ns
);
13532 gfc_traverse_ns (ns
, resolve_values
);
13538 for (d
= ns
->data
; d
; d
= d
->next
)
13542 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
13544 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
13546 if (ns
->common_root
!= NULL
)
13547 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
13549 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
13550 resolve_equivalence (eq
);
13552 /* Warn about unused labels. */
13553 if (warn_unused_label
)
13554 warn_unused_fortran_label (ns
->st_labels
);
13556 gfc_resolve_uops (ns
->uop_root
);
13558 gfc_current_ns
= old_ns
;
13562 /* Call resolve_code recursively. */
13565 resolve_codes (gfc_namespace
*ns
)
13568 bitmap_obstack old_obstack
;
13570 if (ns
->resolved
== 1)
13573 for (n
= ns
->contained
; n
; n
= n
->sibling
)
13576 gfc_current_ns
= ns
;
13578 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
13579 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
13582 /* Set to an out of range value. */
13583 current_entry_id
= -1;
13585 old_obstack
= labels_obstack
;
13586 bitmap_obstack_initialize (&labels_obstack
);
13588 resolve_code (ns
->code
, ns
);
13590 bitmap_obstack_release (&labels_obstack
);
13591 labels_obstack
= old_obstack
;
13595 /* This function is called after a complete program unit has been compiled.
13596 Its purpose is to examine all of the expressions associated with a program
13597 unit, assign types to all intermediate expressions, make sure that all
13598 assignments are to compatible types and figure out which names refer to
13599 which functions or subroutines. */
13602 gfc_resolve (gfc_namespace
*ns
)
13604 gfc_namespace
*old_ns
;
13605 code_stack
*old_cs_base
;
13611 old_ns
= gfc_current_ns
;
13612 old_cs_base
= cs_base
;
13614 resolve_types (ns
);
13615 resolve_codes (ns
);
13617 gfc_current_ns
= old_ns
;
13618 cs_base
= old_cs_base
;
13621 gfc_run_passes (ns
);