1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
30 #include "arith.h" /* For gfc_compare_expr(). */
31 #include "dependency.h"
33 #include "target-memory.h" /* for gfc_simplify_transfer */
34 #include "constructor.h"
36 /* Types used in equivalence statements. */
40 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
44 /* Stack to keep track of the nesting of blocks as we move through the
45 code. See resolve_branch() and resolve_code(). */
47 typedef struct code_stack
49 struct gfc_code
*head
, *current
;
50 struct code_stack
*prev
;
52 /* This bitmap keeps track of the targets valid for a branch from
53 inside this block except for END {IF|SELECT}s of enclosing
55 bitmap reachable_labels
;
59 static code_stack
*cs_base
= NULL
;
62 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
64 static int forall_flag
;
65 static int do_concurrent_flag
;
67 /* True when we are resolving an expression that is an actual argument to
69 static bool actual_arg
= false;
70 /* True when we are resolving an expression that is the first actual argument
72 static bool first_actual_arg
= false;
75 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
77 static int omp_workshare_flag
;
79 /* Nonzero if we are processing a formal arglist. The corresponding function
80 resets the flag each time that it is read. */
81 static int formal_arg_flag
= 0;
83 /* True if we are resolving a specification expression. */
84 static bool specification_expr
= false;
86 /* The id of the last entry seen. */
87 static int current_entry_id
;
89 /* We use bitmaps to determine if a branch target is valid. */
90 static bitmap_obstack labels_obstack
;
92 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
93 static bool inquiry_argument
= false;
97 gfc_is_formal_arg (void)
99 return formal_arg_flag
;
102 /* Is the symbol host associated? */
104 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
106 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
115 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
116 an ABSTRACT derived-type. If where is not NULL, an error message with that
117 locus is printed, optionally using name. */
120 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
122 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
127 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
128 name
, where
, ts
->u
.derived
->name
);
130 gfc_error ("ABSTRACT type '%s' used at %L",
131 ts
->u
.derived
->name
, where
);
142 check_proc_interface (gfc_symbol
*ifc
, locus
*where
)
144 /* Several checks for F08:C1216. */
145 if (ifc
->attr
.procedure
)
147 gfc_error ("Interface '%s' at %L is declared "
148 "in a later PROCEDURE statement", ifc
->name
, where
);
153 /* For generic interfaces, check if there is
154 a specific procedure with the same name. */
155 gfc_interface
*gen
= ifc
->generic
;
156 while (gen
&& strcmp (gen
->sym
->name
, ifc
->name
) != 0)
160 gfc_error ("Interface '%s' at %L may not be generic",
165 if (ifc
->attr
.proc
== PROC_ST_FUNCTION
)
167 gfc_error ("Interface '%s' at %L may not be a statement function",
171 if (gfc_is_intrinsic (ifc
, 0, ifc
->declared_at
)
172 || gfc_is_intrinsic (ifc
, 1, ifc
->declared_at
))
173 ifc
->attr
.intrinsic
= 1;
174 if (ifc
->attr
.intrinsic
&& !gfc_intrinsic_actual_ok (ifc
->name
, 0))
176 gfc_error ("Intrinsic procedure '%s' not allowed in "
177 "PROCEDURE statement at %L", ifc
->name
, where
);
180 if (!ifc
->attr
.if_source
&& !ifc
->attr
.intrinsic
&& ifc
->name
[0] != '\0')
182 gfc_error ("Interface '%s' at %L must be explicit", ifc
->name
, where
);
189 static void resolve_symbol (gfc_symbol
*sym
);
192 /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */
195 resolve_procedure_interface (gfc_symbol
*sym
)
197 gfc_symbol
*ifc
= sym
->ts
.interface
;
204 gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
205 sym
->name
, &sym
->declared_at
);
208 if (check_proc_interface (ifc
, &sym
->declared_at
) == FAILURE
)
211 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
213 /* Resolve interface and copy attributes. */
214 resolve_symbol (ifc
);
215 if (ifc
->attr
.intrinsic
)
216 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
220 sym
->ts
= ifc
->result
->ts
;
225 sym
->ts
.interface
= ifc
;
226 sym
->attr
.function
= ifc
->attr
.function
;
227 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
228 gfc_copy_formal_args (sym
, ifc
, IFSRC_DECL
);
230 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
231 sym
->attr
.pointer
= ifc
->attr
.pointer
;
232 sym
->attr
.pure
= ifc
->attr
.pure
;
233 sym
->attr
.elemental
= ifc
->attr
.elemental
;
234 sym
->attr
.dimension
= ifc
->attr
.dimension
;
235 sym
->attr
.contiguous
= ifc
->attr
.contiguous
;
236 sym
->attr
.recursive
= ifc
->attr
.recursive
;
237 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
238 sym
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
239 sym
->attr
.is_bind_c
= ifc
->attr
.is_bind_c
;
240 sym
->attr
.class_ok
= ifc
->attr
.class_ok
;
241 /* Copy array spec. */
242 sym
->as
= gfc_copy_array_spec (ifc
->as
);
246 for (i
= 0; i
< sym
->as
->rank
; i
++)
248 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
249 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
252 /* Copy char length. */
253 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
255 sym
->ts
.u
.cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
256 gfc_expr_replace_symbols (sym
->ts
.u
.cl
->length
, sym
);
257 if (sym
->ts
.u
.cl
->length
&& !sym
->ts
.u
.cl
->resolved
258 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
267 /* Resolve types of formal argument lists. These have to be done early so that
268 the formal argument lists of module procedures can be copied to the
269 containing module before the individual procedures are resolved
270 individually. We also resolve argument lists of procedures in interface
271 blocks because they are self-contained scoping units.
273 Since a dummy argument cannot be a non-dummy procedure, the only
274 resort left for untyped names are the IMPLICIT types. */
277 resolve_formal_arglist (gfc_symbol
*proc
)
279 gfc_formal_arglist
*f
;
281 bool saved_specification_expr
;
284 if (proc
->result
!= NULL
)
289 if (gfc_elemental (proc
)
290 || sym
->attr
.pointer
|| sym
->attr
.allocatable
291 || (sym
->as
&& sym
->as
->rank
!= 0))
293 proc
->attr
.always_explicit
= 1;
294 sym
->attr
.always_explicit
= 1;
299 for (f
= proc
->formal
; f
; f
= f
->next
)
307 /* Alternate return placeholder. */
308 if (gfc_elemental (proc
))
309 gfc_error ("Alternate return specifier in elemental subroutine "
310 "'%s' at %L is not allowed", proc
->name
,
312 if (proc
->attr
.function
)
313 gfc_error ("Alternate return specifier in function "
314 "'%s' at %L is not allowed", proc
->name
,
318 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
319 && resolve_procedure_interface (sym
) == FAILURE
)
322 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
323 resolve_formal_arglist (sym
);
325 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
327 if (sym
->attr
.flavor
== FL_UNKNOWN
)
328 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
332 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
333 && (!sym
->attr
.function
|| sym
->result
== sym
))
334 gfc_set_default_type (sym
, 1, sym
->ns
);
337 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
338 ? CLASS_DATA (sym
)->as
: sym
->as
;
340 saved_specification_expr
= specification_expr
;
341 specification_expr
= true;
342 gfc_resolve_array_spec (as
, 0);
343 specification_expr
= saved_specification_expr
;
345 /* We can't tell if an array with dimension (:) is assumed or deferred
346 shape until we know if it has the pointer or allocatable attributes.
348 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
349 && ((sym
->ts
.type
!= BT_CLASS
350 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
351 || (sym
->ts
.type
== BT_CLASS
352 && !(CLASS_DATA (sym
)->attr
.class_pointer
353 || CLASS_DATA (sym
)->attr
.allocatable
)))
354 && sym
->attr
.flavor
!= FL_PROCEDURE
)
356 as
->type
= AS_ASSUMED_SHAPE
;
357 for (i
= 0; i
< as
->rank
; i
++)
358 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
361 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
362 || (as
&& as
->type
== AS_ASSUMED_RANK
)
363 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
364 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
365 && (CLASS_DATA (sym
)->attr
.class_pointer
366 || CLASS_DATA (sym
)->attr
.allocatable
367 || CLASS_DATA (sym
)->attr
.target
))
368 || sym
->attr
.optional
)
370 proc
->attr
.always_explicit
= 1;
372 proc
->result
->attr
.always_explicit
= 1;
375 /* If the flavor is unknown at this point, it has to be a variable.
376 A procedure specification would have already set the type. */
378 if (sym
->attr
.flavor
== FL_UNKNOWN
)
379 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
383 if (sym
->attr
.flavor
== FL_PROCEDURE
)
388 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
389 "also be PURE", sym
->name
, &sym
->declared_at
);
393 else if (!sym
->attr
.pointer
)
395 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
398 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
399 " of pure function '%s' at %L with VALUE "
400 "attribute but without INTENT(IN)",
401 sym
->name
, proc
->name
, &sym
->declared_at
);
403 gfc_error ("Argument '%s' of pure function '%s' at %L must "
404 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
408 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
411 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
412 " of pure subroutine '%s' at %L with VALUE "
413 "attribute but without INTENT", sym
->name
,
414 proc
->name
, &sym
->declared_at
);
416 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
417 "must have its INTENT specified or have the "
418 "VALUE attribute", sym
->name
, proc
->name
,
424 if (proc
->attr
.implicit_pure
)
426 if (sym
->attr
.flavor
== FL_PROCEDURE
)
429 proc
->attr
.implicit_pure
= 0;
431 else if (!sym
->attr
.pointer
)
433 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
435 proc
->attr
.implicit_pure
= 0;
437 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
439 proc
->attr
.implicit_pure
= 0;
443 if (gfc_elemental (proc
))
446 if (sym
->attr
.codimension
447 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
448 && CLASS_DATA (sym
)->attr
.codimension
))
450 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
451 "procedure", sym
->name
, &sym
->declared_at
);
455 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
456 && CLASS_DATA (sym
)->as
))
458 gfc_error ("Argument '%s' of elemental procedure at %L must "
459 "be scalar", sym
->name
, &sym
->declared_at
);
463 if (sym
->attr
.allocatable
464 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
465 && CLASS_DATA (sym
)->attr
.allocatable
))
467 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
468 "have the ALLOCATABLE attribute", sym
->name
,
473 if (sym
->attr
.pointer
474 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
475 && CLASS_DATA (sym
)->attr
.class_pointer
))
477 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
478 "have the POINTER attribute", sym
->name
,
483 if (sym
->attr
.flavor
== FL_PROCEDURE
)
485 gfc_error ("Dummy procedure '%s' not allowed in elemental "
486 "procedure '%s' at %L", sym
->name
, proc
->name
,
491 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
493 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
494 "have its INTENT specified", sym
->name
, proc
->name
,
500 /* Each dummy shall be specified to be scalar. */
501 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
505 gfc_error ("Argument '%s' of statement function at %L must "
506 "be scalar", sym
->name
, &sym
->declared_at
);
510 if (sym
->ts
.type
== BT_CHARACTER
)
512 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
513 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
515 gfc_error ("Character-valued argument '%s' of statement "
516 "function at %L must have constant length",
517 sym
->name
, &sym
->declared_at
);
527 /* Work function called when searching for symbols that have argument lists
528 associated with them. */
531 find_arglists (gfc_symbol
*sym
)
533 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
534 || sym
->attr
.flavor
== FL_DERIVED
)
537 resolve_formal_arglist (sym
);
541 /* Given a namespace, resolve all formal argument lists within the namespace.
545 resolve_formal_arglists (gfc_namespace
*ns
)
550 gfc_traverse_ns (ns
, find_arglists
);
555 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
559 /* If this namespace is not a function or an entry master function,
561 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
562 || sym
->attr
.entry_master
)
565 /* Try to find out of what the return type is. */
566 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
568 t
= gfc_set_default_type (sym
->result
, 0, ns
);
570 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
572 if (sym
->result
== sym
)
573 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
574 sym
->name
, &sym
->declared_at
);
575 else if (!sym
->result
->attr
.proc_pointer
)
576 gfc_error ("Result '%s' of contained function '%s' at %L has "
577 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
578 &sym
->result
->declared_at
);
579 sym
->result
->attr
.untyped
= 1;
583 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
584 type, lists the only ways a character length value of * can be used:
585 dummy arguments of procedures, named constants, and function results
586 in external functions. Internal function results and results of module
587 procedures are not on this list, ergo, not permitted. */
589 if (sym
->result
->ts
.type
== BT_CHARACTER
)
591 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
592 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
594 /* See if this is a module-procedure and adapt error message
597 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
598 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
600 gfc_error ("Character-valued %s '%s' at %L must not be"
602 module_proc
? _("module procedure")
603 : _("internal function"),
604 sym
->name
, &sym
->declared_at
);
610 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
611 introduce duplicates. */
614 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
616 gfc_formal_arglist
*f
, *new_arglist
;
619 for (; new_args
!= NULL
; new_args
= new_args
->next
)
621 new_sym
= new_args
->sym
;
622 /* See if this arg is already in the formal argument list. */
623 for (f
= proc
->formal
; f
; f
= f
->next
)
625 if (new_sym
== f
->sym
)
632 /* Add a new argument. Argument order is not important. */
633 new_arglist
= gfc_get_formal_arglist ();
634 new_arglist
->sym
= new_sym
;
635 new_arglist
->next
= proc
->formal
;
636 proc
->formal
= new_arglist
;
641 /* Flag the arguments that are not present in all entries. */
644 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
646 gfc_formal_arglist
*f
, *head
;
649 for (f
= proc
->formal
; f
; f
= f
->next
)
654 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
656 if (new_args
->sym
== f
->sym
)
663 f
->sym
->attr
.not_always_present
= 1;
668 /* Resolve alternate entry points. If a symbol has multiple entry points we
669 create a new master symbol for the main routine, and turn the existing
670 symbol into an entry point. */
673 resolve_entries (gfc_namespace
*ns
)
675 gfc_namespace
*old_ns
;
679 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
680 static int master_count
= 0;
682 if (ns
->proc_name
== NULL
)
685 /* No need to do anything if this procedure doesn't have alternate entry
690 /* We may already have resolved alternate entry points. */
691 if (ns
->proc_name
->attr
.entry_master
)
694 /* If this isn't a procedure something has gone horribly wrong. */
695 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
697 /* Remember the current namespace. */
698 old_ns
= gfc_current_ns
;
702 /* Add the main entry point to the list of entry points. */
703 el
= gfc_get_entry_list ();
704 el
->sym
= ns
->proc_name
;
706 el
->next
= ns
->entries
;
708 ns
->proc_name
->attr
.entry
= 1;
710 /* If it is a module function, it needs to be in the right namespace
711 so that gfc_get_fake_result_decl can gather up the results. The
712 need for this arose in get_proc_name, where these beasts were
713 left in their own namespace, to keep prior references linked to
714 the entry declaration.*/
715 if (ns
->proc_name
->attr
.function
716 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
719 /* Do the same for entries where the master is not a module
720 procedure. These are retained in the module namespace because
721 of the module procedure declaration. */
722 for (el
= el
->next
; el
; el
= el
->next
)
723 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
724 && el
->sym
->attr
.mod_proc
)
728 /* Add an entry statement for it. */
735 /* Create a new symbol for the master function. */
736 /* Give the internal function a unique name (within this file).
737 Also include the function name so the user has some hope of figuring
738 out what is going on. */
739 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
740 master_count
++, ns
->proc_name
->name
);
741 gfc_get_ha_symbol (name
, &proc
);
742 gcc_assert (proc
!= NULL
);
744 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
745 if (ns
->proc_name
->attr
.subroutine
)
746 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
750 gfc_typespec
*ts
, *fts
;
751 gfc_array_spec
*as
, *fas
;
752 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
754 fas
= ns
->entries
->sym
->as
;
755 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
756 fts
= &ns
->entries
->sym
->result
->ts
;
757 if (fts
->type
== BT_UNKNOWN
)
758 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
759 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
761 ts
= &el
->sym
->result
->ts
;
763 as
= as
? as
: el
->sym
->result
->as
;
764 if (ts
->type
== BT_UNKNOWN
)
765 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
767 if (! gfc_compare_types (ts
, fts
)
768 || (el
->sym
->result
->attr
.dimension
769 != ns
->entries
->sym
->result
->attr
.dimension
)
770 || (el
->sym
->result
->attr
.pointer
771 != ns
->entries
->sym
->result
->attr
.pointer
))
773 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
774 && gfc_compare_array_spec (as
, fas
) == 0)
775 gfc_error ("Function %s at %L has entries with mismatched "
776 "array specifications", ns
->entries
->sym
->name
,
777 &ns
->entries
->sym
->declared_at
);
778 /* The characteristics need to match and thus both need to have
779 the same string length, i.e. both len=*, or both len=4.
780 Having both len=<variable> is also possible, but difficult to
781 check at compile time. */
782 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
783 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
784 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
786 && ts
->u
.cl
->length
->expr_type
787 != fts
->u
.cl
->length
->expr_type
)
789 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
790 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
791 fts
->u
.cl
->length
->value
.integer
) != 0)))
792 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
793 "entries returning variables of different "
794 "string lengths", ns
->entries
->sym
->name
,
795 &ns
->entries
->sym
->declared_at
);
800 sym
= ns
->entries
->sym
->result
;
801 /* All result types the same. */
803 if (sym
->attr
.dimension
)
804 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
805 if (sym
->attr
.pointer
)
806 gfc_add_pointer (&proc
->attr
, NULL
);
810 /* Otherwise the result will be passed through a union by
812 proc
->attr
.mixed_entry_master
= 1;
813 for (el
= ns
->entries
; el
; el
= el
->next
)
815 sym
= el
->sym
->result
;
816 if (sym
->attr
.dimension
)
818 if (el
== ns
->entries
)
819 gfc_error ("FUNCTION result %s can't be an array in "
820 "FUNCTION %s at %L", sym
->name
,
821 ns
->entries
->sym
->name
, &sym
->declared_at
);
823 gfc_error ("ENTRY result %s can't be an array in "
824 "FUNCTION %s at %L", sym
->name
,
825 ns
->entries
->sym
->name
, &sym
->declared_at
);
827 else if (sym
->attr
.pointer
)
829 if (el
== ns
->entries
)
830 gfc_error ("FUNCTION result %s can't be a POINTER in "
831 "FUNCTION %s at %L", sym
->name
,
832 ns
->entries
->sym
->name
, &sym
->declared_at
);
834 gfc_error ("ENTRY result %s can't be a POINTER in "
835 "FUNCTION %s at %L", sym
->name
,
836 ns
->entries
->sym
->name
, &sym
->declared_at
);
841 if (ts
->type
== BT_UNKNOWN
)
842 ts
= gfc_get_default_type (sym
->name
, NULL
);
846 if (ts
->kind
== gfc_default_integer_kind
)
850 if (ts
->kind
== gfc_default_real_kind
851 || ts
->kind
== gfc_default_double_kind
)
855 if (ts
->kind
== gfc_default_complex_kind
)
859 if (ts
->kind
== gfc_default_logical_kind
)
863 /* We will issue error elsewhere. */
871 if (el
== ns
->entries
)
872 gfc_error ("FUNCTION result %s can't be of type %s "
873 "in FUNCTION %s at %L", sym
->name
,
874 gfc_typename (ts
), ns
->entries
->sym
->name
,
877 gfc_error ("ENTRY result %s can't be of type %s "
878 "in FUNCTION %s at %L", sym
->name
,
879 gfc_typename (ts
), ns
->entries
->sym
->name
,
886 proc
->attr
.access
= ACCESS_PRIVATE
;
887 proc
->attr
.entry_master
= 1;
889 /* Merge all the entry point arguments. */
890 for (el
= ns
->entries
; el
; el
= el
->next
)
891 merge_argument_lists (proc
, el
->sym
->formal
);
893 /* Check the master formal arguments for any that are not
894 present in all entry points. */
895 for (el
= ns
->entries
; el
; el
= el
->next
)
896 check_argument_lists (proc
, el
->sym
->formal
);
898 /* Use the master function for the function body. */
899 ns
->proc_name
= proc
;
901 /* Finalize the new symbols. */
902 gfc_commit_symbols ();
904 /* Restore the original namespace. */
905 gfc_current_ns
= old_ns
;
909 /* Resolve common variables. */
911 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
913 gfc_symbol
*csym
= sym
;
915 for (; csym
; csym
= csym
->common_next
)
917 if (csym
->value
|| csym
->attr
.data
)
919 if (!csym
->ns
->is_block_data
)
920 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
921 "but only in BLOCK DATA initialization is "
922 "allowed", csym
->name
, &csym
->declared_at
);
923 else if (!named_common
)
924 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
925 "in a blank COMMON but initialization is only "
926 "allowed in named common blocks", csym
->name
,
930 if (csym
->ts
.type
!= BT_DERIVED
)
933 if (!(csym
->ts
.u
.derived
->attr
.sequence
934 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
935 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
936 "has neither the SEQUENCE nor the BIND(C) "
937 "attribute", csym
->name
, &csym
->declared_at
);
938 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
939 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
940 "has an ultimate component that is "
941 "allocatable", csym
->name
, &csym
->declared_at
);
942 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
943 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
944 "may not have default initializer", csym
->name
,
947 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
948 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
952 /* Resolve common blocks. */
954 resolve_common_blocks (gfc_symtree
*common_root
)
958 if (common_root
== NULL
)
961 if (common_root
->left
)
962 resolve_common_blocks (common_root
->left
);
963 if (common_root
->right
)
964 resolve_common_blocks (common_root
->right
);
966 resolve_common_vars (common_root
->n
.common
->head
, true);
968 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
972 if (sym
->attr
.flavor
== FL_PARAMETER
)
973 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
974 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
976 if (sym
->attr
.external
)
977 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
978 sym
->name
, &common_root
->n
.common
->where
);
980 if (sym
->attr
.intrinsic
)
981 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
982 sym
->name
, &common_root
->n
.common
->where
);
983 else if (sym
->attr
.result
984 || gfc_is_function_return_value (sym
, gfc_current_ns
))
985 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
986 "that is also a function result", sym
->name
,
987 &common_root
->n
.common
->where
);
988 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
989 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
990 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
991 "that is also a global procedure", sym
->name
,
992 &common_root
->n
.common
->where
);
996 /* Resolve contained function types. Because contained functions can call one
997 another, they have to be worked out before any of the contained procedures
1000 The good news is that if a function doesn't already have a type, the only
1001 way it can get one is through an IMPLICIT type or a RESULT variable, because
1002 by definition contained functions are contained namespace they're contained
1003 in, not in a sibling or parent namespace. */
1006 resolve_contained_functions (gfc_namespace
*ns
)
1008 gfc_namespace
*child
;
1011 resolve_formal_arglists (ns
);
1013 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1015 /* Resolve alternate entry points first. */
1016 resolve_entries (child
);
1018 /* Then check function return types. */
1019 resolve_contained_fntype (child
->proc_name
, child
);
1020 for (el
= child
->entries
; el
; el
= el
->next
)
1021 resolve_contained_fntype (el
->sym
, child
);
1026 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
1029 /* Resolve all of the elements of a structure constructor and make sure that
1030 the types are correct. The 'init' flag indicates that the given
1031 constructor is an initializer. */
1034 resolve_structure_cons (gfc_expr
*expr
, int init
)
1036 gfc_constructor
*cons
;
1037 gfc_component
*comp
;
1043 if (expr
->ts
.type
== BT_DERIVED
)
1044 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1046 cons
= gfc_constructor_first (expr
->value
.constructor
);
1048 /* See if the user is trying to invoke a structure constructor for one of
1049 the iso_c_binding derived types. */
1050 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1051 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1052 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
1054 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
1055 expr
->ts
.u
.derived
->name
, &(expr
->where
));
1059 /* Return if structure constructor is c_null_(fun)prt. */
1060 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1061 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1062 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
1065 /* A constructor may have references if it is the result of substituting a
1066 parameter variable. In this case we just pull out the component we
1069 comp
= expr
->ref
->u
.c
.sym
->components
;
1071 comp
= expr
->ts
.u
.derived
->components
;
1073 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1080 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1086 rank
= comp
->as
? comp
->as
->rank
: 0;
1087 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1088 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1090 gfc_error ("The rank of the element in the structure "
1091 "constructor at %L does not match that of the "
1092 "component (%d/%d)", &cons
->expr
->where
,
1093 cons
->expr
->rank
, rank
);
1097 /* If we don't have the right type, try to convert it. */
1099 if (!comp
->attr
.proc_pointer
&&
1100 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1103 if (strcmp (comp
->name
, "_extends") == 0)
1105 /* Can afford to be brutal with the _extends initializer.
1106 The derived type can get lost because it is PRIVATE
1107 but it is not usage constrained by the standard. */
1108 cons
->expr
->ts
= comp
->ts
;
1111 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1112 gfc_error ("The element in the structure constructor at %L, "
1113 "for pointer component '%s', is %s but should be %s",
1114 &cons
->expr
->where
, comp
->name
,
1115 gfc_basic_typename (cons
->expr
->ts
.type
),
1116 gfc_basic_typename (comp
->ts
.type
));
1118 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1121 /* For strings, the length of the constructor should be the same as
1122 the one of the structure, ensure this if the lengths are known at
1123 compile time and when we are dealing with PARAMETER or structure
1125 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1126 && comp
->ts
.u
.cl
->length
1127 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1128 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1129 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1130 && cons
->expr
->rank
!= 0
1131 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1132 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1134 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1135 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1137 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1138 to make use of the gfc_resolve_character_array_constructor
1139 machinery. The expression is later simplified away to
1140 an array of string literals. */
1141 gfc_expr
*para
= cons
->expr
;
1142 cons
->expr
= gfc_get_expr ();
1143 cons
->expr
->ts
= para
->ts
;
1144 cons
->expr
->where
= para
->where
;
1145 cons
->expr
->expr_type
= EXPR_ARRAY
;
1146 cons
->expr
->rank
= para
->rank
;
1147 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1148 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1149 para
, &cons
->expr
->where
);
1151 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1154 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1155 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1157 gfc_charlen
*cl
, *cl2
;
1160 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1162 if (cl
== cons
->expr
->ts
.u
.cl
)
1170 cl2
->next
= cl
->next
;
1172 gfc_free_expr (cl
->length
);
1176 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1177 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1178 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1179 gfc_resolve_character_array_constructor (cons
->expr
);
1183 if (cons
->expr
->expr_type
== EXPR_NULL
1184 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1185 || comp
->attr
.proc_pointer
1186 || (comp
->ts
.type
== BT_CLASS
1187 && (CLASS_DATA (comp
)->attr
.class_pointer
1188 || CLASS_DATA (comp
)->attr
.allocatable
))))
1191 gfc_error ("The NULL in the structure constructor at %L is "
1192 "being applied to component '%s', which is neither "
1193 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1197 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1199 /* Check procedure pointer interface. */
1200 gfc_symbol
*s2
= NULL
;
1205 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1208 s2
= c2
->ts
.interface
;
1211 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1213 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1214 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1216 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1218 s2
= cons
->expr
->symtree
->n
.sym
;
1219 name
= cons
->expr
->symtree
->n
.sym
->name
;
1222 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1223 err
, sizeof (err
), NULL
, NULL
))
1225 gfc_error ("Interface mismatch for procedure-pointer component "
1226 "'%s' in structure constructor at %L: %s",
1227 comp
->name
, &cons
->expr
->where
, err
);
1232 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1233 || cons
->expr
->expr_type
== EXPR_NULL
)
1236 a
= gfc_expr_attr (cons
->expr
);
1238 if (!a
.pointer
&& !a
.target
)
1241 gfc_error ("The element in the structure constructor at %L, "
1242 "for pointer component '%s' should be a POINTER or "
1243 "a TARGET", &cons
->expr
->where
, comp
->name
);
1248 /* F08:C461. Additional checks for pointer initialization. */
1252 gfc_error ("Pointer initialization target at %L "
1253 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1258 gfc_error ("Pointer initialization target at %L "
1259 "must have the SAVE attribute", &cons
->expr
->where
);
1263 /* F2003, C1272 (3). */
1264 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1265 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1266 || gfc_is_coindexed (cons
->expr
)))
1269 gfc_error ("Invalid expression in the structure constructor for "
1270 "pointer component '%s' at %L in PURE procedure",
1271 comp
->name
, &cons
->expr
->where
);
1274 if (gfc_implicit_pure (NULL
)
1275 && cons
->expr
->expr_type
== EXPR_VARIABLE
1276 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1277 || gfc_is_coindexed (cons
->expr
)))
1278 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1286 /****************** Expression name resolution ******************/
1288 /* Returns 0 if a symbol was not declared with a type or
1289 attribute declaration statement, nonzero otherwise. */
1292 was_declared (gfc_symbol
*sym
)
1298 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1301 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1302 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1303 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1304 || a
.asynchronous
|| a
.codimension
)
1311 /* Determine if a symbol is generic or not. */
1314 generic_sym (gfc_symbol
*sym
)
1318 if (sym
->attr
.generic
||
1319 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1322 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1325 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1332 return generic_sym (s
);
1339 /* Determine if a symbol is specific or not. */
1342 specific_sym (gfc_symbol
*sym
)
1346 if (sym
->attr
.if_source
== IFSRC_IFBODY
1347 || sym
->attr
.proc
== PROC_MODULE
1348 || sym
->attr
.proc
== PROC_INTERNAL
1349 || sym
->attr
.proc
== PROC_ST_FUNCTION
1350 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1351 || sym
->attr
.external
)
1354 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1357 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1359 return (s
== NULL
) ? 0 : specific_sym (s
);
1363 /* Figure out if the procedure is specific, generic or unknown. */
1366 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1370 procedure_kind (gfc_symbol
*sym
)
1372 if (generic_sym (sym
))
1373 return PTYPE_GENERIC
;
1375 if (specific_sym (sym
))
1376 return PTYPE_SPECIFIC
;
1378 return PTYPE_UNKNOWN
;
1381 /* Check references to assumed size arrays. The flag need_full_assumed_size
1382 is nonzero when matching actual arguments. */
1384 static int need_full_assumed_size
= 0;
1387 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1389 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1392 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1393 What should it be? */
1394 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1395 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1396 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1398 gfc_error ("The upper bound in the last dimension must "
1399 "appear in the reference to the assumed size "
1400 "array '%s' at %L", sym
->name
, &e
->where
);
1407 /* Look for bad assumed size array references in argument expressions
1408 of elemental and array valued intrinsic procedures. Since this is
1409 called from procedure resolution functions, it only recurses at
1413 resolve_assumed_size_actual (gfc_expr
*e
)
1418 switch (e
->expr_type
)
1421 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1426 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1427 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1438 /* Check a generic procedure, passed as an actual argument, to see if
1439 there is a matching specific name. If none, it is an error, and if
1440 more than one, the reference is ambiguous. */
1442 count_specific_procs (gfc_expr
*e
)
1449 sym
= e
->symtree
->n
.sym
;
1451 for (p
= sym
->generic
; p
; p
= p
->next
)
1452 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1454 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1460 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1464 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1465 "argument at %L", sym
->name
, &e
->where
);
1471 /* See if a call to sym could possibly be a not allowed RECURSION because of
1472 a missing RECURSIVE declaration. This means that either sym is the current
1473 context itself, or sym is the parent of a contained procedure calling its
1474 non-RECURSIVE containing procedure.
1475 This also works if sym is an ENTRY. */
1478 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1480 gfc_symbol
* proc_sym
;
1481 gfc_symbol
* context_proc
;
1482 gfc_namespace
* real_context
;
1484 if (sym
->attr
.flavor
== FL_PROGRAM
1485 || sym
->attr
.flavor
== FL_DERIVED
)
1488 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1490 /* If we've got an ENTRY, find real procedure. */
1491 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1492 proc_sym
= sym
->ns
->entries
->sym
;
1496 /* If sym is RECURSIVE, all is well of course. */
1497 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1500 /* Find the context procedure's "real" symbol if it has entries.
1501 We look for a procedure symbol, so recurse on the parents if we don't
1502 find one (like in case of a BLOCK construct). */
1503 for (real_context
= context
; ; real_context
= real_context
->parent
)
1505 /* We should find something, eventually! */
1506 gcc_assert (real_context
);
1508 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1509 : real_context
->proc_name
);
1511 /* In some special cases, there may not be a proc_name, like for this
1513 real(bad_kind()) function foo () ...
1514 when checking the call to bad_kind ().
1515 In these cases, we simply return here and assume that the
1520 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1524 /* A call from sym's body to itself is recursion, of course. */
1525 if (context_proc
== proc_sym
)
1528 /* The same is true if context is a contained procedure and sym the
1530 if (context_proc
->attr
.contained
)
1532 gfc_symbol
* parent_proc
;
1534 gcc_assert (context
->parent
);
1535 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1536 : context
->parent
->proc_name
);
1538 if (parent_proc
== proc_sym
)
1546 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1547 its typespec and formal argument list. */
1550 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1552 gfc_intrinsic_sym
* isym
= NULL
;
1558 /* Already resolved. */
1559 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1562 /* We already know this one is an intrinsic, so we don't call
1563 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1564 gfc_find_subroutine directly to check whether it is a function or
1567 if (sym
->intmod_sym_id
)
1568 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1569 else if (!sym
->attr
.subroutine
)
1570 isym
= gfc_find_function (sym
->name
);
1574 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1575 && !sym
->attr
.implicit_type
)
1576 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1577 " ignored", sym
->name
, &sym
->declared_at
);
1579 if (!sym
->attr
.function
&&
1580 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1585 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1587 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1589 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1590 " specifier", sym
->name
, &sym
->declared_at
);
1594 if (!sym
->attr
.subroutine
&&
1595 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1600 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1605 gfc_copy_formal_args_intr (sym
, isym
);
1607 /* Check it is actually available in the standard settings. */
1608 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1611 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1612 " available in the current standard settings but %s. Use"
1613 " an appropriate -std=* option or enable -fall-intrinsics"
1614 " in order to use it.",
1615 sym
->name
, &sym
->declared_at
, symstd
);
1623 /* Resolve a procedure expression, like passing it to a called procedure or as
1624 RHS for a procedure pointer assignment. */
1627 resolve_procedure_expression (gfc_expr
* expr
)
1631 if (expr
->expr_type
!= EXPR_VARIABLE
)
1633 gcc_assert (expr
->symtree
);
1635 sym
= expr
->symtree
->n
.sym
;
1637 if (sym
->attr
.intrinsic
)
1638 gfc_resolve_intrinsic (sym
, &expr
->where
);
1640 if (sym
->attr
.flavor
!= FL_PROCEDURE
1641 || (sym
->attr
.function
&& sym
->result
== sym
))
1644 /* A non-RECURSIVE procedure that is used as procedure expression within its
1645 own body is in danger of being called recursively. */
1646 if (is_illegal_recursion (sym
, gfc_current_ns
))
1647 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1648 " itself recursively. Declare it RECURSIVE or use"
1649 " -frecursive", sym
->name
, &expr
->where
);
1655 /* Resolve an actual argument list. Most of the time, this is just
1656 resolving the expressions in the list.
1657 The exception is that we sometimes have to decide whether arguments
1658 that look like procedure arguments are really simple variable
1662 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1663 bool no_formal_args
)
1666 gfc_symtree
*parent_st
;
1668 int save_need_full_assumed_size
;
1669 gfc_try return_value
= FAILURE
;
1670 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1673 first_actual_arg
= true;
1675 for (; arg
; arg
= arg
->next
)
1680 /* Check the label is a valid branching target. */
1683 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1685 gfc_error ("Label %d referenced at %L is never defined",
1686 arg
->label
->value
, &arg
->label
->where
);
1690 first_actual_arg
= false;
1694 if (e
->expr_type
== EXPR_VARIABLE
1695 && e
->symtree
->n
.sym
->attr
.generic
1697 && count_specific_procs (e
) != 1)
1700 if (e
->ts
.type
!= BT_PROCEDURE
)
1702 save_need_full_assumed_size
= need_full_assumed_size
;
1703 if (e
->expr_type
!= EXPR_VARIABLE
)
1704 need_full_assumed_size
= 0;
1705 if (gfc_resolve_expr (e
) != SUCCESS
)
1707 need_full_assumed_size
= save_need_full_assumed_size
;
1711 /* See if the expression node should really be a variable reference. */
1713 sym
= e
->symtree
->n
.sym
;
1715 if (sym
->attr
.flavor
== FL_PROCEDURE
1716 || sym
->attr
.intrinsic
1717 || sym
->attr
.external
)
1721 /* If a procedure is not already determined to be something else
1722 check if it is intrinsic. */
1723 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1724 sym
->attr
.intrinsic
= 1;
1726 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1728 gfc_error ("Statement function '%s' at %L is not allowed as an "
1729 "actual argument", sym
->name
, &e
->where
);
1732 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1733 sym
->attr
.subroutine
);
1734 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1736 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1737 "actual argument", sym
->name
, &e
->where
);
1740 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1741 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1743 if (gfc_notify_std (GFC_STD_F2008
,
1744 "Internal procedure '%s' is"
1745 " used as actual argument at %L",
1746 sym
->name
, &e
->where
) == FAILURE
)
1750 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1752 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1753 "allowed as an actual argument at %L", sym
->name
,
1757 /* Check if a generic interface has a specific procedure
1758 with the same name before emitting an error. */
1759 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1762 /* Just in case a specific was found for the expression. */
1763 sym
= e
->symtree
->n
.sym
;
1765 /* If the symbol is the function that names the current (or
1766 parent) scope, then we really have a variable reference. */
1768 if (gfc_is_function_return_value (sym
, sym
->ns
))
1771 /* If all else fails, see if we have a specific intrinsic. */
1772 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1774 gfc_intrinsic_sym
*isym
;
1776 isym
= gfc_find_function (sym
->name
);
1777 if (isym
== NULL
|| !isym
->specific
)
1779 gfc_error ("Unable to find a specific INTRINSIC procedure "
1780 "for the reference '%s' at %L", sym
->name
,
1785 sym
->attr
.intrinsic
= 1;
1786 sym
->attr
.function
= 1;
1789 if (gfc_resolve_expr (e
) == FAILURE
)
1794 /* See if the name is a module procedure in a parent unit. */
1796 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1799 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1801 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1805 if (parent_st
== NULL
)
1808 sym
= parent_st
->n
.sym
;
1809 e
->symtree
= parent_st
; /* Point to the right thing. */
1811 if (sym
->attr
.flavor
== FL_PROCEDURE
1812 || sym
->attr
.intrinsic
1813 || sym
->attr
.external
)
1815 if (gfc_resolve_expr (e
) == FAILURE
)
1821 e
->expr_type
= EXPR_VARIABLE
;
1823 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1824 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1825 && CLASS_DATA (sym
)->as
))
1827 e
->rank
= sym
->ts
.type
== BT_CLASS
1828 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1829 e
->ref
= gfc_get_ref ();
1830 e
->ref
->type
= REF_ARRAY
;
1831 e
->ref
->u
.ar
.type
= AR_FULL
;
1832 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1833 ? CLASS_DATA (sym
)->as
: sym
->as
;
1836 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1837 primary.c (match_actual_arg). If above code determines that it
1838 is a variable instead, it needs to be resolved as it was not
1839 done at the beginning of this function. */
1840 save_need_full_assumed_size
= need_full_assumed_size
;
1841 if (e
->expr_type
!= EXPR_VARIABLE
)
1842 need_full_assumed_size
= 0;
1843 if (gfc_resolve_expr (e
) != SUCCESS
)
1845 need_full_assumed_size
= save_need_full_assumed_size
;
1848 /* Check argument list functions %VAL, %LOC and %REF. There is
1849 nothing to do for %REF. */
1850 if (arg
->name
&& arg
->name
[0] == '%')
1852 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1854 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1856 gfc_error ("By-value argument at %L is not of numeric "
1863 gfc_error ("By-value argument at %L cannot be an array or "
1864 "an array section", &e
->where
);
1868 /* Intrinsics are still PROC_UNKNOWN here. However,
1869 since same file external procedures are not resolvable
1870 in gfortran, it is a good deal easier to leave them to
1872 if (ptype
!= PROC_UNKNOWN
1873 && ptype
!= PROC_DUMMY
1874 && ptype
!= PROC_EXTERNAL
1875 && ptype
!= PROC_MODULE
)
1877 gfc_error ("By-value argument at %L is not allowed "
1878 "in this context", &e
->where
);
1883 /* Statement functions have already been excluded above. */
1884 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1885 && e
->ts
.type
== BT_PROCEDURE
)
1887 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1889 gfc_error ("Passing internal procedure at %L by location "
1890 "not allowed", &e
->where
);
1896 /* Fortran 2008, C1237. */
1897 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1898 && gfc_has_ultimate_pointer (e
))
1900 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1901 "component", &e
->where
);
1905 first_actual_arg
= false;
1908 return_value
= SUCCESS
;
1911 actual_arg
= actual_arg_sav
;
1912 first_actual_arg
= first_actual_arg_sav
;
1914 return return_value
;
1918 /* Do the checks of the actual argument list that are specific to elemental
1919 procedures. If called with c == NULL, we have a function, otherwise if
1920 expr == NULL, we have a subroutine. */
1923 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1925 gfc_actual_arglist
*arg0
;
1926 gfc_actual_arglist
*arg
;
1927 gfc_symbol
*esym
= NULL
;
1928 gfc_intrinsic_sym
*isym
= NULL
;
1930 gfc_intrinsic_arg
*iformal
= NULL
;
1931 gfc_formal_arglist
*eformal
= NULL
;
1932 bool formal_optional
= false;
1933 bool set_by_optional
= false;
1937 /* Is this an elemental procedure? */
1938 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1940 if (expr
->value
.function
.esym
!= NULL
1941 && expr
->value
.function
.esym
->attr
.elemental
)
1943 arg0
= expr
->value
.function
.actual
;
1944 esym
= expr
->value
.function
.esym
;
1946 else if (expr
->value
.function
.isym
!= NULL
1947 && expr
->value
.function
.isym
->elemental
)
1949 arg0
= expr
->value
.function
.actual
;
1950 isym
= expr
->value
.function
.isym
;
1955 else if (c
&& c
->ext
.actual
!= NULL
)
1957 arg0
= c
->ext
.actual
;
1959 if (c
->resolved_sym
)
1960 esym
= c
->resolved_sym
;
1962 esym
= c
->symtree
->n
.sym
;
1965 if (!esym
->attr
.elemental
)
1971 /* The rank of an elemental is the rank of its array argument(s). */
1972 for (arg
= arg0
; arg
; arg
= arg
->next
)
1974 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
1976 rank
= arg
->expr
->rank
;
1977 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1978 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1979 set_by_optional
= true;
1981 /* Function specific; set the result rank and shape. */
1985 if (!expr
->shape
&& arg
->expr
->shape
)
1987 expr
->shape
= gfc_get_shape (rank
);
1988 for (i
= 0; i
< rank
; i
++)
1989 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1996 /* If it is an array, it shall not be supplied as an actual argument
1997 to an elemental procedure unless an array of the same rank is supplied
1998 as an actual argument corresponding to a nonoptional dummy argument of
1999 that elemental procedure(12.4.1.5). */
2000 formal_optional
= false;
2002 iformal
= isym
->formal
;
2004 eformal
= esym
->formal
;
2006 for (arg
= arg0
; arg
; arg
= arg
->next
)
2010 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2011 formal_optional
= true;
2012 eformal
= eformal
->next
;
2014 else if (isym
&& iformal
)
2016 if (iformal
->optional
)
2017 formal_optional
= true;
2018 iformal
= iformal
->next
;
2021 formal_optional
= true;
2023 if (pedantic
&& arg
->expr
!= NULL
2024 && arg
->expr
->expr_type
== EXPR_VARIABLE
2025 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2028 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2029 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2031 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2032 "MISSING, it cannot be the actual argument of an "
2033 "ELEMENTAL procedure unless there is a non-optional "
2034 "argument with the same rank (12.4.1.5)",
2035 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2039 for (arg
= arg0
; arg
; arg
= arg
->next
)
2041 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2044 /* Being elemental, the last upper bound of an assumed size array
2045 argument must be present. */
2046 if (resolve_assumed_size_actual (arg
->expr
))
2049 /* Elemental procedure's array actual arguments must conform. */
2052 if (gfc_check_conformance (arg
->expr
, e
,
2053 "elemental procedure") == FAILURE
)
2060 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2061 is an array, the intent inout/out variable needs to be also an array. */
2062 if (rank
> 0 && esym
&& expr
== NULL
)
2063 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2064 arg
= arg
->next
, eformal
= eformal
->next
)
2065 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2066 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2067 && arg
->expr
&& arg
->expr
->rank
== 0)
2069 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2070 "ELEMENTAL subroutine '%s' is a scalar, but another "
2071 "actual argument is an array", &arg
->expr
->where
,
2072 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2073 : "INOUT", eformal
->sym
->name
, esym
->name
);
2080 /* This function does the checking of references to global procedures
2081 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2082 77 and 95 standards. It checks for a gsymbol for the name, making
2083 one if it does not already exist. If it already exists, then the
2084 reference being resolved must correspond to the type of gsymbol.
2085 Otherwise, the new symbol is equipped with the attributes of the
2086 reference. The corresponding code that is called in creating
2087 global entities is parse.c.
2089 In addition, for all but -std=legacy, the gsymbols are used to
2090 check the interfaces of external procedures from the same file.
2091 The namespace of the gsymbol is resolved and then, once this is
2092 done the interface is checked. */
2096 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2098 if (!gsym_ns
->proc_name
->attr
.recursive
)
2101 if (sym
->ns
== gsym_ns
)
2104 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2111 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2113 if (gsym_ns
->entries
)
2115 gfc_entry_list
*entry
= gsym_ns
->entries
;
2117 for (; entry
; entry
= entry
->next
)
2119 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2121 if (strcmp (gsym_ns
->proc_name
->name
,
2122 sym
->ns
->proc_name
->name
) == 0)
2126 && strcmp (gsym_ns
->proc_name
->name
,
2127 sym
->ns
->parent
->proc_name
->name
) == 0)
2136 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2137 gfc_actual_arglist
**actual
, int sub
)
2141 enum gfc_symbol_type type
;
2143 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2145 gsym
= gfc_get_gsymbol (sym
->name
);
2147 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2148 gfc_global_used (gsym
, where
);
2150 if (gfc_option
.flag_whole_file
2151 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2152 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2153 && gsym
->type
!= GSYM_UNKNOWN
2155 && gsym
->ns
->resolved
!= -1
2156 && gsym
->ns
->proc_name
2157 && not_in_recursive (sym
, gsym
->ns
)
2158 && not_entry_self_reference (sym
, gsym
->ns
))
2160 gfc_symbol
*def_sym
;
2162 /* Resolve the gsymbol namespace if needed. */
2163 if (!gsym
->ns
->resolved
)
2165 gfc_dt_list
*old_dt_list
;
2166 struct gfc_omp_saved_state old_omp_state
;
2168 /* Stash away derived types so that the backend_decls do not
2170 old_dt_list
= gfc_derived_types
;
2171 gfc_derived_types
= NULL
;
2172 /* And stash away openmp state. */
2173 gfc_omp_save_and_clear_state (&old_omp_state
);
2175 gfc_resolve (gsym
->ns
);
2177 /* Store the new derived types with the global namespace. */
2178 if (gfc_derived_types
)
2179 gsym
->ns
->derived_types
= gfc_derived_types
;
2181 /* Restore the derived types of this namespace. */
2182 gfc_derived_types
= old_dt_list
;
2183 /* And openmp state. */
2184 gfc_omp_restore_state (&old_omp_state
);
2187 /* Make sure that translation for the gsymbol occurs before
2188 the procedure currently being resolved. */
2189 ns
= gfc_global_ns_list
;
2190 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2192 if (ns
->sibling
== gsym
->ns
)
2194 ns
->sibling
= gsym
->ns
->sibling
;
2195 gsym
->ns
->sibling
= gfc_global_ns_list
;
2196 gfc_global_ns_list
= gsym
->ns
;
2201 def_sym
= gsym
->ns
->proc_name
;
2202 if (def_sym
->attr
.entry_master
)
2204 gfc_entry_list
*entry
;
2205 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2206 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2208 def_sym
= entry
->sym
;
2213 /* Differences in constant character lengths. */
2214 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2216 long int l1
= 0, l2
= 0;
2217 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2218 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2221 && cl1
->length
!= NULL
2222 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2223 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2226 && cl2
->length
!= NULL
2227 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2228 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2230 if (l1
&& l2
&& l1
!= l2
)
2231 gfc_error ("Character length mismatch in return type of "
2232 "function '%s' at %L (%ld/%ld)", sym
->name
,
2233 &sym
->declared_at
, l1
, l2
);
2236 /* Type mismatch of function return type and expected type. */
2237 if (sym
->attr
.function
2238 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2239 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2240 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2241 gfc_typename (&def_sym
->ts
));
2243 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2245 gfc_formal_arglist
*arg
= def_sym
->formal
;
2246 for ( ; arg
; arg
= arg
->next
)
2249 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2250 else if (arg
->sym
->attr
.allocatable
2251 || arg
->sym
->attr
.asynchronous
2252 || arg
->sym
->attr
.optional
2253 || arg
->sym
->attr
.pointer
2254 || arg
->sym
->attr
.target
2255 || arg
->sym
->attr
.value
2256 || arg
->sym
->attr
.volatile_
)
2258 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2259 "has an attribute that requires an explicit "
2260 "interface for this procedure", arg
->sym
->name
,
2261 sym
->name
, &sym
->declared_at
);
2264 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2265 else if (arg
->sym
&& arg
->sym
->as
2266 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2268 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2269 "argument '%s' must have an explicit interface",
2270 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2273 /* TS 29113, 6.2. */
2274 else if (arg
->sym
&& arg
->sym
->as
2275 && arg
->sym
->as
->type
== AS_ASSUMED_RANK
)
2277 gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
2278 "argument '%s' must have an explicit interface",
2279 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2282 /* F2008, 12.4.2.2 (2c) */
2283 else if (arg
->sym
->attr
.codimension
)
2285 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2286 "'%s' must have an explicit interface",
2287 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2290 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2291 else if (false) /* TODO: is a parametrized derived type */
2293 gfc_error ("Procedure '%s' at %L with parametrized derived "
2294 "type argument '%s' must have an explicit "
2295 "interface", sym
->name
, &sym
->declared_at
,
2299 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2300 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2302 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2303 "argument '%s' must have an explicit interface",
2304 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2307 /* As assumed-type is unlimited polymorphic (cf. above).
2308 See also TS 29113, Note 6.1. */
2309 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2311 gfc_error ("Procedure '%s' at %L with assumed-type dummy "
2312 "argument '%s' must have an explicit interface",
2313 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2318 if (def_sym
->attr
.function
)
2320 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2321 if (def_sym
->as
&& def_sym
->as
->rank
2322 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2323 gfc_error ("The reference to function '%s' at %L either needs an "
2324 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2327 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2328 if ((def_sym
->result
->attr
.pointer
2329 || def_sym
->result
->attr
.allocatable
)
2330 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2331 || def_sym
->result
->attr
.pointer
2332 != sym
->result
->attr
.pointer
2333 || def_sym
->result
->attr
.allocatable
2334 != sym
->result
->attr
.allocatable
))
2335 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2336 "result must have an explicit interface", sym
->name
,
2339 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2340 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2341 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2343 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2345 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2346 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2348 gfc_error ("Nonconstant character-length function '%s' at %L "
2349 "must have an explicit interface", sym
->name
,
2355 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2356 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2358 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2359 "interface", sym
->name
, &sym
->declared_at
);
2362 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2363 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2365 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2366 "an explicit interface", sym
->name
, &sym
->declared_at
);
2369 if (gfc_option
.flag_whole_file
== 1
2370 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2371 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2372 gfc_errors_to_warnings (1);
2374 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2375 gfc_procedure_use (def_sym
, actual
, where
);
2377 gfc_errors_to_warnings (0);
2380 if (gsym
->type
== GSYM_UNKNOWN
)
2383 gsym
->where
= *where
;
2390 /************* Function resolution *************/
2392 /* Resolve a function call known to be generic.
2393 Section 14.1.2.4.1. */
2396 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2400 if (sym
->attr
.generic
)
2402 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2405 expr
->value
.function
.name
= s
->name
;
2406 expr
->value
.function
.esym
= s
;
2408 if (s
->ts
.type
!= BT_UNKNOWN
)
2410 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2411 expr
->ts
= s
->result
->ts
;
2414 expr
->rank
= s
->as
->rank
;
2415 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2416 expr
->rank
= s
->result
->as
->rank
;
2418 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2423 /* TODO: Need to search for elemental references in generic
2427 if (sym
->attr
.intrinsic
)
2428 return gfc_intrinsic_func_interface (expr
, 0);
2435 resolve_generic_f (gfc_expr
*expr
)
2439 gfc_interface
*intr
= NULL
;
2441 sym
= expr
->symtree
->n
.sym
;
2445 m
= resolve_generic_f0 (expr
, sym
);
2448 else if (m
== MATCH_ERROR
)
2453 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2454 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2457 if (sym
->ns
->parent
== NULL
)
2459 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2463 if (!generic_sym (sym
))
2467 /* Last ditch attempt. See if the reference is to an intrinsic
2468 that possesses a matching interface. 14.1.2.4 */
2469 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2471 gfc_error ("There is no specific function for the generic '%s' "
2472 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2478 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2481 return resolve_structure_cons (expr
, 0);
2484 m
= gfc_intrinsic_func_interface (expr
, 0);
2489 gfc_error ("Generic function '%s' at %L is not consistent with a "
2490 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2497 /* Resolve a function call known to be specific. */
2500 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2504 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2506 if (sym
->attr
.dummy
)
2508 sym
->attr
.proc
= PROC_DUMMY
;
2512 sym
->attr
.proc
= PROC_EXTERNAL
;
2516 if (sym
->attr
.proc
== PROC_MODULE
2517 || sym
->attr
.proc
== PROC_ST_FUNCTION
2518 || sym
->attr
.proc
== PROC_INTERNAL
)
2521 if (sym
->attr
.intrinsic
)
2523 m
= gfc_intrinsic_func_interface (expr
, 1);
2527 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2528 "with an intrinsic", sym
->name
, &expr
->where
);
2536 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2539 expr
->ts
= sym
->result
->ts
;
2542 expr
->value
.function
.name
= sym
->name
;
2543 expr
->value
.function
.esym
= sym
;
2544 if (sym
->as
!= NULL
)
2545 expr
->rank
= sym
->as
->rank
;
2552 resolve_specific_f (gfc_expr
*expr
)
2557 sym
= expr
->symtree
->n
.sym
;
2561 m
= resolve_specific_f0 (sym
, expr
);
2564 if (m
== MATCH_ERROR
)
2567 if (sym
->ns
->parent
== NULL
)
2570 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2576 gfc_error ("Unable to resolve the specific function '%s' at %L",
2577 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2583 /* Resolve a procedure call not known to be generic nor specific. */
2586 resolve_unknown_f (gfc_expr
*expr
)
2591 sym
= expr
->symtree
->n
.sym
;
2593 if (sym
->attr
.dummy
)
2595 sym
->attr
.proc
= PROC_DUMMY
;
2596 expr
->value
.function
.name
= sym
->name
;
2600 /* See if we have an intrinsic function reference. */
2602 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2604 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2609 /* The reference is to an external name. */
2611 sym
->attr
.proc
= PROC_EXTERNAL
;
2612 expr
->value
.function
.name
= sym
->name
;
2613 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2615 if (sym
->as
!= NULL
)
2616 expr
->rank
= sym
->as
->rank
;
2618 /* Type of the expression is either the type of the symbol or the
2619 default type of the symbol. */
2622 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2624 if (sym
->ts
.type
!= BT_UNKNOWN
)
2628 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2630 if (ts
->type
== BT_UNKNOWN
)
2632 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2633 sym
->name
, &expr
->where
);
2644 /* Return true, if the symbol is an external procedure. */
2646 is_external_proc (gfc_symbol
*sym
)
2648 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2649 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2650 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2651 && !sym
->attr
.proc_pointer
2652 && !sym
->attr
.use_assoc
2660 /* Figure out if a function reference is pure or not. Also set the name
2661 of the function for a potential error message. Return nonzero if the
2662 function is PURE, zero if not. */
2664 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2667 pure_function (gfc_expr
*e
, const char **name
)
2673 if (e
->symtree
!= NULL
2674 && e
->symtree
->n
.sym
!= NULL
2675 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2676 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2678 if (e
->value
.function
.esym
)
2680 pure
= gfc_pure (e
->value
.function
.esym
);
2681 *name
= e
->value
.function
.esym
->name
;
2683 else if (e
->value
.function
.isym
)
2685 pure
= e
->value
.function
.isym
->pure
2686 || e
->value
.function
.isym
->elemental
;
2687 *name
= e
->value
.function
.isym
->name
;
2691 /* Implicit functions are not pure. */
2693 *name
= e
->value
.function
.name
;
2701 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2702 int *f ATTRIBUTE_UNUSED
)
2706 /* Don't bother recursing into other statement functions
2707 since they will be checked individually for purity. */
2708 if (e
->expr_type
!= EXPR_FUNCTION
2710 || e
->symtree
->n
.sym
== sym
2711 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2714 return pure_function (e
, &name
) ? false : true;
2719 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2721 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2726 is_scalar_expr_ptr (gfc_expr
*expr
)
2728 gfc_try retval
= SUCCESS
;
2733 /* See if we have a gfc_ref, which means we have a substring, array
2734 reference, or a component. */
2735 if (expr
->ref
!= NULL
)
2738 while (ref
->next
!= NULL
)
2744 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2745 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2750 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2752 else if (ref
->u
.ar
.type
== AR_FULL
)
2754 /* The user can give a full array if the array is of size 1. */
2755 if (ref
->u
.ar
.as
!= NULL
2756 && ref
->u
.ar
.as
->rank
== 1
2757 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2758 && ref
->u
.ar
.as
->lower
[0] != NULL
2759 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2760 && ref
->u
.ar
.as
->upper
[0] != NULL
2761 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2763 /* If we have a character string, we need to check if
2764 its length is one. */
2765 if (expr
->ts
.type
== BT_CHARACTER
)
2767 if (expr
->ts
.u
.cl
== NULL
2768 || expr
->ts
.u
.cl
->length
== NULL
2769 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2775 /* We have constant lower and upper bounds. If the
2776 difference between is 1, it can be considered a
2778 FIXME: Use gfc_dep_compare_expr instead. */
2779 start
= (int) mpz_get_si
2780 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2781 end
= (int) mpz_get_si
2782 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2783 if (end
- start
+ 1 != 1)
2798 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2800 /* Character string. Make sure it's of length 1. */
2801 if (expr
->ts
.u
.cl
== NULL
2802 || expr
->ts
.u
.cl
->length
== NULL
2803 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2806 else if (expr
->rank
!= 0)
2813 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2814 and, in the case of c_associated, set the binding label based on
2818 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2819 gfc_symbol
**new_sym
)
2821 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2822 int optional_arg
= 0;
2823 gfc_try retval
= SUCCESS
;
2824 gfc_symbol
*args_sym
;
2825 gfc_typespec
*arg_ts
;
2826 symbol_attribute arg_attr
;
2828 if (args
->expr
->expr_type
== EXPR_CONSTANT
2829 || args
->expr
->expr_type
== EXPR_OP
2830 || args
->expr
->expr_type
== EXPR_NULL
)
2832 gfc_error ("Argument to '%s' at %L is not a variable",
2833 sym
->name
, &(args
->expr
->where
));
2837 args_sym
= args
->expr
->symtree
->n
.sym
;
2839 /* The typespec for the actual arg should be that stored in the expr
2840 and not necessarily that of the expr symbol (args_sym), because
2841 the actual expression could be a part-ref of the expr symbol. */
2842 arg_ts
= &(args
->expr
->ts
);
2843 arg_attr
= gfc_expr_attr (args
->expr
);
2845 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2847 /* If the user gave two args then they are providing something for
2848 the optional arg (the second cptr). Therefore, set the name and
2849 binding label to the c_associated for two cptrs. Otherwise,
2850 set c_associated to expect one cptr. */
2854 sprintf (name
, "%s_2", sym
->name
);
2860 sprintf (name
, "%s_1", sym
->name
);
2864 /* Get a new symbol for the version of c_associated that
2866 *new_sym
= get_iso_c_sym (sym
, name
, NULL
, optional_arg
);
2868 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2869 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2871 sprintf (name
, "%s", sym
->name
);
2873 /* Error check the call. */
2874 if (args
->next
!= NULL
)
2876 gfc_error_now ("More actual than formal arguments in '%s' "
2877 "call at %L", name
, &(args
->expr
->where
));
2880 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2885 /* Make sure we have either the target or pointer attribute. */
2886 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2888 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2889 "a TARGET or an associated pointer",
2891 sym
->name
, &(args
->expr
->where
));
2895 if (gfc_is_coindexed (args
->expr
))
2897 gfc_error_now ("Coindexed argument not permitted"
2898 " in '%s' call at %L", name
,
2899 &(args
->expr
->where
));
2903 /* Follow references to make sure there are no array
2905 seen_section
= false;
2907 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2909 if (ref
->type
== REF_ARRAY
)
2911 if (ref
->u
.ar
.type
== AR_SECTION
)
2912 seen_section
= true;
2914 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2917 for (r
= ref
->next
; r
; r
=r
->next
)
2918 if (r
->type
== REF_COMPONENT
)
2920 gfc_error_now ("Array section not permitted"
2921 " in '%s' call at %L", name
,
2922 &(args
->expr
->where
));
2930 if (seen_section
&& retval
== SUCCESS
)
2931 gfc_warning ("Array section in '%s' call at %L", name
,
2932 &(args
->expr
->where
));
2934 /* See if we have interoperable type and type param. */
2935 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2936 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2938 if (args_sym
->attr
.target
== 1)
2940 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2941 has the target attribute and is interoperable. */
2942 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2943 allocatable variable that has the TARGET attribute and
2944 is not an array of zero size. */
2945 if (args_sym
->attr
.allocatable
== 1)
2947 if (args_sym
->attr
.dimension
!= 0
2948 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2950 gfc_error_now ("Allocatable variable '%s' used as a "
2951 "parameter to '%s' at %L must not be "
2952 "an array of zero size",
2953 args_sym
->name
, sym
->name
,
2954 &(args
->expr
->where
));
2960 /* A non-allocatable target variable with C
2961 interoperable type and type parameters must be
2963 if (args_sym
&& args_sym
->attr
.dimension
)
2965 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2967 gfc_error ("Assumed-shape array '%s' at %L "
2968 "cannot be an argument to the "
2969 "procedure '%s' because "
2970 "it is not C interoperable",
2972 &(args
->expr
->where
), sym
->name
);
2975 else if (args_sym
->as
->type
== AS_DEFERRED
)
2977 gfc_error ("Deferred-shape array '%s' at %L "
2978 "cannot be an argument to the "
2979 "procedure '%s' because "
2980 "it is not C interoperable",
2982 &(args
->expr
->where
), sym
->name
);
2987 /* Make sure it's not a character string. Arrays of
2988 any type should be ok if the variable is of a C
2989 interoperable type. */
2990 if (arg_ts
->type
== BT_CHARACTER
)
2991 if (arg_ts
->u
.cl
!= NULL
2992 && (arg_ts
->u
.cl
->length
== NULL
2993 || arg_ts
->u
.cl
->length
->expr_type
2996 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2998 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3000 gfc_error_now ("CHARACTER argument '%s' to '%s' "
3001 "at %L must have a length of 1",
3002 args_sym
->name
, sym
->name
,
3003 &(args
->expr
->where
));
3008 else if (arg_attr
.pointer
3009 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3011 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
3013 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
3014 "associated scalar POINTER", args_sym
->name
,
3015 sym
->name
, &(args
->expr
->where
));
3021 /* The parameter is not required to be C interoperable. If it
3022 is not C interoperable, it must be a nonpolymorphic scalar
3023 with no length type parameters. It still must have either
3024 the pointer or target attribute, and it can be
3025 allocatable (but must be allocated when c_loc is called). */
3026 if (args
->expr
->rank
!= 0
3027 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3029 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
3030 "scalar", args_sym
->name
, sym
->name
,
3031 &(args
->expr
->where
));
3034 else if (arg_ts
->type
== BT_CHARACTER
3035 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3037 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
3038 "%L must have a length of 1",
3039 args_sym
->name
, sym
->name
,
3040 &(args
->expr
->where
));
3043 else if (arg_ts
->type
== BT_CLASS
)
3045 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
3046 "polymorphic", args_sym
->name
, sym
->name
,
3047 &(args
->expr
->where
));
3052 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
3054 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
3056 /* TODO: Update this error message to allow for procedure
3057 pointers once they are implemented. */
3058 gfc_error_now ("Argument '%s' to '%s' at %L must be a "
3060 args_sym
->name
, sym
->name
,
3061 &(args
->expr
->where
));
3064 else if (args_sym
->attr
.is_bind_c
!= 1
3065 && gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable "
3066 "argument '%s' to '%s' at %L",
3067 args_sym
->name
, sym
->name
,
3068 &(args
->expr
->where
)) == FAILURE
)
3072 /* for c_loc/c_funloc, the new symbol is the same as the old one */
3077 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
3078 "iso_c_binding function: '%s'!\n", sym
->name
);
3085 /* Resolve a function call, which means resolving the arguments, then figuring
3086 out which entity the name refers to. */
3089 resolve_function (gfc_expr
*expr
)
3091 gfc_actual_arglist
*arg
;
3096 procedure_type p
= PROC_INTRINSIC
;
3097 bool no_formal_args
;
3101 sym
= expr
->symtree
->n
.sym
;
3103 /* If this is a procedure pointer component, it has already been resolved. */
3104 if (gfc_is_proc_ptr_comp (expr
))
3107 if (sym
&& sym
->attr
.intrinsic
3108 && gfc_resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3111 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3113 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3117 /* If this ia a deferred TBP with an abstract interface (which may
3118 of course be referenced), expr->value.function.esym will be set. */
3119 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3121 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3122 sym
->name
, &expr
->where
);
3126 if (sym
&& specification_expr
&& sym
->attr
.function
3127 && gfc_current_ns
->proc_name
3128 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3129 sym
->attr
.public_used
= 1;
3132 /* Switch off assumed size checking and do this again for certain kinds
3133 of procedure, once the procedure itself is resolved. */
3134 need_full_assumed_size
++;
3136 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3137 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3139 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3140 inquiry_argument
= true;
3141 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3143 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3144 p
, no_formal_args
) == FAILURE
)
3146 inquiry_argument
= false;
3150 inquiry_argument
= false;
3152 /* Need to setup the call to the correct c_associated, depending on
3153 the number of cptrs to user gives to compare. */
3154 if (sym
&& sym
->attr
.is_iso_c
== 1)
3156 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3160 /* Get the symtree for the new symbol (resolved func).
3161 the old one will be freed later, when it's no longer used. */
3162 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3165 /* Resume assumed_size checking. */
3166 need_full_assumed_size
--;
3168 /* If the procedure is external, check for usage. */
3169 if (sym
&& is_external_proc (sym
))
3170 resolve_global_procedure (sym
, &expr
->where
,
3171 &expr
->value
.function
.actual
, 0);
3173 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3175 && sym
->ts
.u
.cl
->length
== NULL
3177 && !sym
->ts
.deferred
3178 && expr
->value
.function
.esym
== NULL
3179 && !sym
->attr
.contained
)
3181 /* Internal procedures are taken care of in resolve_contained_fntype. */
3182 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3183 "be used at %L since it is not a dummy argument",
3184 sym
->name
, &expr
->where
);
3188 /* See if function is already resolved. */
3190 if (expr
->value
.function
.name
!= NULL
)
3192 if (expr
->ts
.type
== BT_UNKNOWN
)
3198 /* Apply the rules of section 14.1.2. */
3200 switch (procedure_kind (sym
))
3203 t
= resolve_generic_f (expr
);
3206 case PTYPE_SPECIFIC
:
3207 t
= resolve_specific_f (expr
);
3211 t
= resolve_unknown_f (expr
);
3215 gfc_internal_error ("resolve_function(): bad function type");
3219 /* If the expression is still a function (it might have simplified),
3220 then we check to see if we are calling an elemental function. */
3222 if (expr
->expr_type
!= EXPR_FUNCTION
)
3225 temp
= need_full_assumed_size
;
3226 need_full_assumed_size
= 0;
3228 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3231 if (omp_workshare_flag
3232 && expr
->value
.function
.esym
3233 && ! gfc_elemental (expr
->value
.function
.esym
))
3235 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3236 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3241 #define GENERIC_ID expr->value.function.isym->id
3242 else if (expr
->value
.function
.actual
!= NULL
3243 && expr
->value
.function
.isym
!= NULL
3244 && GENERIC_ID
!= GFC_ISYM_LBOUND
3245 && GENERIC_ID
!= GFC_ISYM_LEN
3246 && GENERIC_ID
!= GFC_ISYM_LOC
3247 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3249 /* Array intrinsics must also have the last upper bound of an
3250 assumed size array argument. UBOUND and SIZE have to be
3251 excluded from the check if the second argument is anything
3254 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3256 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3257 && arg
->next
!= NULL
&& arg
->next
->expr
)
3259 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3262 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3265 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3270 if (arg
->expr
!= NULL
3271 && arg
->expr
->rank
> 0
3272 && resolve_assumed_size_actual (arg
->expr
))
3278 need_full_assumed_size
= temp
;
3281 if (!pure_function (expr
, &name
) && name
)
3285 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3286 "FORALL %s", name
, &expr
->where
,
3287 forall_flag
== 2 ? "mask" : "block");
3290 else if (do_concurrent_flag
)
3292 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3293 "DO CONCURRENT %s", name
, &expr
->where
,
3294 do_concurrent_flag
== 2 ? "mask" : "block");
3297 else if (gfc_pure (NULL
))
3299 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3300 "procedure within a PURE procedure", name
, &expr
->where
);
3304 if (gfc_implicit_pure (NULL
))
3305 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3308 /* Functions without the RECURSIVE attribution are not allowed to
3309 * call themselves. */
3310 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3313 esym
= expr
->value
.function
.esym
;
3315 if (is_illegal_recursion (esym
, gfc_current_ns
))
3317 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3318 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3319 " function '%s' is not RECURSIVE",
3320 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3322 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3323 " is not RECURSIVE", esym
->name
, &expr
->where
);
3329 /* Character lengths of use associated functions may contains references to
3330 symbols not referenced from the current program unit otherwise. Make sure
3331 those symbols are marked as referenced. */
3333 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3334 && expr
->value
.function
.esym
->attr
.use_assoc
)
3336 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3339 /* Make sure that the expression has a typespec that works. */
3340 if (expr
->ts
.type
== BT_UNKNOWN
)
3342 if (expr
->symtree
->n
.sym
->result
3343 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3344 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3345 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3352 /************* Subroutine resolution *************/
3355 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3361 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3362 sym
->name
, &c
->loc
);
3363 else if (do_concurrent_flag
)
3364 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3365 "PURE", sym
->name
, &c
->loc
);
3366 else if (gfc_pure (NULL
))
3367 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3370 if (gfc_implicit_pure (NULL
))
3371 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3376 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3380 if (sym
->attr
.generic
)
3382 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3385 c
->resolved_sym
= s
;
3386 pure_subroutine (c
, s
);
3390 /* TODO: Need to search for elemental references in generic interface. */
3393 if (sym
->attr
.intrinsic
)
3394 return gfc_intrinsic_sub_interface (c
, 0);
3401 resolve_generic_s (gfc_code
*c
)
3406 sym
= c
->symtree
->n
.sym
;
3410 m
= resolve_generic_s0 (c
, sym
);
3413 else if (m
== MATCH_ERROR
)
3417 if (sym
->ns
->parent
== NULL
)
3419 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3423 if (!generic_sym (sym
))
3427 /* Last ditch attempt. See if the reference is to an intrinsic
3428 that possesses a matching interface. 14.1.2.4 */
3429 sym
= c
->symtree
->n
.sym
;
3431 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3433 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3434 sym
->name
, &c
->loc
);
3438 m
= gfc_intrinsic_sub_interface (c
, 0);
3442 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3443 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3449 /* Set the name and binding label of the subroutine symbol in the call
3450 expression represented by 'c' to include the type and kind of the
3451 second parameter. This function is for resolving the appropriate
3452 version of c_f_pointer() and c_f_procpointer(). For example, a
3453 call to c_f_pointer() for a default integer pointer could have a
3454 name of c_f_pointer_i4. If no second arg exists, which is an error
3455 for these two functions, it defaults to the generic symbol's name
3456 and binding label. */
3459 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3460 char *name
, const char **binding_label
)
3462 gfc_expr
*arg
= NULL
;
3466 /* The second arg of c_f_pointer and c_f_procpointer determines
3467 the type and kind for the procedure name. */
3468 arg
= c
->ext
.actual
->next
->expr
;
3472 /* Set up the name to have the given symbol's name,
3473 plus the type and kind. */
3474 /* a derived type is marked with the type letter 'u' */
3475 if (arg
->ts
.type
== BT_DERIVED
)
3478 kind
= 0; /* set the kind as 0 for now */
3482 type
= gfc_type_letter (arg
->ts
.type
);
3483 kind
= arg
->ts
.kind
;
3486 if (arg
->ts
.type
== BT_CHARACTER
)
3487 /* Kind info for character strings not needed. */
3490 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3491 /* Set up the binding label as the given symbol's label plus
3492 the type and kind. */
3493 *binding_label
= gfc_get_string ("%s_%c%d", sym
->binding_label
, type
,
3498 /* If the second arg is missing, set the name and label as
3499 was, cause it should at least be found, and the missing
3500 arg error will be caught by compare_parameters(). */
3501 sprintf (name
, "%s", sym
->name
);
3502 *binding_label
= sym
->binding_label
;
3509 /* Resolve a generic version of the iso_c_binding procedure given
3510 (sym) to the specific one based on the type and kind of the
3511 argument(s). Currently, this function resolves c_f_pointer() and
3512 c_f_procpointer based on the type and kind of the second argument
3513 (FPTR). Other iso_c_binding procedures aren't specially handled.
3514 Upon successfully exiting, c->resolved_sym will hold the resolved
3515 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3519 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3521 gfc_symbol
*new_sym
;
3522 /* this is fine, since we know the names won't use the max */
3523 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3524 const char* binding_label
;
3525 /* default to success; will override if find error */
3526 match m
= MATCH_YES
;
3528 /* Make sure the actual arguments are in the necessary order (based on the
3529 formal args) before resolving. */
3530 if (gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
)) == FAILURE
)
3532 c
->resolved_sym
= sym
;
3536 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3537 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3539 set_name_and_label (c
, sym
, name
, &binding_label
);
3541 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3543 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3545 gfc_actual_arglist
*arg1
= c
->ext
.actual
;
3546 gfc_actual_arglist
*arg2
= c
->ext
.actual
->next
;
3547 gfc_actual_arglist
*arg3
= c
->ext
.actual
->next
->next
;
3549 /* Check first argument (CPTR). */
3550 if (arg1
->expr
->ts
.type
!= BT_DERIVED
3551 || arg1
->expr
->ts
.u
.derived
->intmod_sym_id
!= ISOCBINDING_PTR
)
3553 gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
3554 "the type C_PTR", &arg1
->expr
->where
);
3558 /* Check second argument (FPTR). */
3559 if (arg2
->expr
->ts
.type
== BT_CLASS
)
3561 gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
3562 "polymorphic", &arg2
->expr
->where
);
3566 /* Make sure we got a third arg (SHAPE) if the second arg has
3567 non-zero rank. We must also check that the type and rank are
3568 correct since we short-circuit this check in
3569 gfc_procedure_use() (called above to sort actual args). */
3570 if (arg2
->expr
->rank
!= 0)
3572 if (arg3
== NULL
|| arg3
->expr
== NULL
)
3575 gfc_error ("Missing SHAPE argument for call to %s at %L",
3576 sym
->name
, &c
->loc
);
3578 else if (arg3
->expr
->ts
.type
!= BT_INTEGER
3579 || arg3
->expr
->rank
!= 1)
3582 gfc_error ("SHAPE argument for call to %s at %L must be "
3583 "a rank 1 INTEGER array", sym
->name
, &c
->loc
);
3588 else /* ISOCBINDING_F_PROCPOINTER. */
3591 && (c
->ext
.actual
->expr
->ts
.type
!= BT_DERIVED
3592 || c
->ext
.actual
->expr
->ts
.u
.derived
->intmod_sym_id
3593 != ISOCBINDING_FUNPTR
))
3595 gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
3596 "C_FUNPTR", &c
->ext
.actual
->expr
->where
);
3599 if (c
->ext
.actual
&& c
->ext
.actual
->next
3600 && !gfc_expr_attr (c
->ext
.actual
->next
->expr
).is_bind_c
3601 && gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable "
3602 "procedure-pointer at %L to C_F_FUNPOINTER",
3603 &c
->ext
.actual
->next
->expr
->where
)
3608 if (m
!= MATCH_ERROR
)
3610 /* the 1 means to add the optional arg to formal list */
3611 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3613 /* for error reporting, say it's declared where the original was */
3614 new_sym
->declared_at
= sym
->declared_at
;
3619 /* no differences for c_loc or c_funloc */
3623 /* set the resolved symbol */
3624 if (m
!= MATCH_ERROR
)
3625 c
->resolved_sym
= new_sym
;
3627 c
->resolved_sym
= sym
;
3633 /* Resolve a subroutine call known to be specific. */
3636 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3640 if(sym
->attr
.is_iso_c
)
3642 m
= gfc_iso_c_sub_interface (c
,sym
);
3646 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3648 if (sym
->attr
.dummy
)
3650 sym
->attr
.proc
= PROC_DUMMY
;
3654 sym
->attr
.proc
= PROC_EXTERNAL
;
3658 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3661 if (sym
->attr
.intrinsic
)
3663 m
= gfc_intrinsic_sub_interface (c
, 1);
3667 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3668 "with an intrinsic", sym
->name
, &c
->loc
);
3676 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3678 c
->resolved_sym
= sym
;
3679 pure_subroutine (c
, sym
);
3686 resolve_specific_s (gfc_code
*c
)
3691 sym
= c
->symtree
->n
.sym
;
3695 m
= resolve_specific_s0 (c
, sym
);
3698 if (m
== MATCH_ERROR
)
3701 if (sym
->ns
->parent
== NULL
)
3704 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3710 sym
= c
->symtree
->n
.sym
;
3711 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3712 sym
->name
, &c
->loc
);
3718 /* Resolve a subroutine call not known to be generic nor specific. */
3721 resolve_unknown_s (gfc_code
*c
)
3725 sym
= c
->symtree
->n
.sym
;
3727 if (sym
->attr
.dummy
)
3729 sym
->attr
.proc
= PROC_DUMMY
;
3733 /* See if we have an intrinsic function reference. */
3735 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3737 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3742 /* The reference is to an external name. */
3745 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3747 c
->resolved_sym
= sym
;
3749 pure_subroutine (c
, sym
);
3755 /* Resolve a subroutine call. Although it was tempting to use the same code
3756 for functions, subroutines and functions are stored differently and this
3757 makes things awkward. */
3760 resolve_call (gfc_code
*c
)
3763 procedure_type ptype
= PROC_INTRINSIC
;
3764 gfc_symbol
*csym
, *sym
;
3765 bool no_formal_args
;
3767 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3769 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3771 gfc_error ("'%s' at %L has a type, which is not consistent with "
3772 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3776 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3779 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3780 sym
= st
? st
->n
.sym
: NULL
;
3781 if (sym
&& csym
!= sym
3782 && sym
->ns
== gfc_current_ns
3783 && sym
->attr
.flavor
== FL_PROCEDURE
3784 && sym
->attr
.contained
)
3787 if (csym
->attr
.generic
)
3788 c
->symtree
->n
.sym
= sym
;
3791 csym
= c
->symtree
->n
.sym
;
3795 /* If this ia a deferred TBP with an abstract interface
3796 (which may of course be referenced), c->expr1 will be set. */
3797 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3799 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3800 csym
->name
, &c
->loc
);
3804 /* Subroutines without the RECURSIVE attribution are not allowed to
3805 * call themselves. */
3806 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3808 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3809 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3810 " subroutine '%s' is not RECURSIVE",
3811 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3813 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3814 " is not RECURSIVE", csym
->name
, &c
->loc
);
3819 /* Switch off assumed size checking and do this again for certain kinds
3820 of procedure, once the procedure itself is resolved. */
3821 need_full_assumed_size
++;
3824 ptype
= csym
->attr
.proc
;
3826 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3827 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3828 no_formal_args
) == FAILURE
)
3831 /* Resume assumed_size checking. */
3832 need_full_assumed_size
--;
3834 /* If external, check for usage. */
3835 if (csym
&& is_external_proc (csym
))
3836 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3839 if (c
->resolved_sym
== NULL
)
3841 c
->resolved_isym
= NULL
;
3842 switch (procedure_kind (csym
))
3845 t
= resolve_generic_s (c
);
3848 case PTYPE_SPECIFIC
:
3849 t
= resolve_specific_s (c
);
3853 t
= resolve_unknown_s (c
);
3857 gfc_internal_error ("resolve_subroutine(): bad function type");
3861 /* Some checks of elemental subroutine actual arguments. */
3862 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3869 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3870 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3871 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3872 if their shapes do not match. If either op1->shape or op2->shape is
3873 NULL, return SUCCESS. */
3876 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3883 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3885 for (i
= 0; i
< op1
->rank
; i
++)
3887 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3889 gfc_error ("Shapes for operands at %L and %L are not conformable",
3890 &op1
->where
, &op2
->where
);
3901 /* Resolve an operator expression node. This can involve replacing the
3902 operation with a user defined function call. */
3905 resolve_operator (gfc_expr
*e
)
3907 gfc_expr
*op1
, *op2
;
3909 bool dual_locus_error
;
3912 /* Resolve all subnodes-- give them types. */
3914 switch (e
->value
.op
.op
)
3917 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3920 /* Fall through... */
3923 case INTRINSIC_UPLUS
:
3924 case INTRINSIC_UMINUS
:
3925 case INTRINSIC_PARENTHESES
:
3926 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3931 /* Typecheck the new node. */
3933 op1
= e
->value
.op
.op1
;
3934 op2
= e
->value
.op
.op2
;
3935 dual_locus_error
= false;
3937 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3938 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3940 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3944 switch (e
->value
.op
.op
)
3946 case INTRINSIC_UPLUS
:
3947 case INTRINSIC_UMINUS
:
3948 if (op1
->ts
.type
== BT_INTEGER
3949 || op1
->ts
.type
== BT_REAL
3950 || op1
->ts
.type
== BT_COMPLEX
)
3956 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3957 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3960 case INTRINSIC_PLUS
:
3961 case INTRINSIC_MINUS
:
3962 case INTRINSIC_TIMES
:
3963 case INTRINSIC_DIVIDE
:
3964 case INTRINSIC_POWER
:
3965 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3967 gfc_type_convert_binary (e
, 1);
3972 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3973 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3974 gfc_typename (&op2
->ts
));
3977 case INTRINSIC_CONCAT
:
3978 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3979 && op1
->ts
.kind
== op2
->ts
.kind
)
3981 e
->ts
.type
= BT_CHARACTER
;
3982 e
->ts
.kind
= op1
->ts
.kind
;
3987 _("Operands of string concatenation operator at %%L are %s/%s"),
3988 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3994 case INTRINSIC_NEQV
:
3995 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3997 e
->ts
.type
= BT_LOGICAL
;
3998 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3999 if (op1
->ts
.kind
< e
->ts
.kind
)
4000 gfc_convert_type (op1
, &e
->ts
, 2);
4001 else if (op2
->ts
.kind
< e
->ts
.kind
)
4002 gfc_convert_type (op2
, &e
->ts
, 2);
4006 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
4007 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4008 gfc_typename (&op2
->ts
));
4013 if (op1
->ts
.type
== BT_LOGICAL
)
4015 e
->ts
.type
= BT_LOGICAL
;
4016 e
->ts
.kind
= op1
->ts
.kind
;
4020 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4021 gfc_typename (&op1
->ts
));
4025 case INTRINSIC_GT_OS
:
4027 case INTRINSIC_GE_OS
:
4029 case INTRINSIC_LT_OS
:
4031 case INTRINSIC_LE_OS
:
4032 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4034 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4038 /* Fall through... */
4041 case INTRINSIC_EQ_OS
:
4043 case INTRINSIC_NE_OS
:
4044 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4045 && op1
->ts
.kind
== op2
->ts
.kind
)
4047 e
->ts
.type
= BT_LOGICAL
;
4048 e
->ts
.kind
= gfc_default_logical_kind
;
4052 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4054 gfc_type_convert_binary (e
, 1);
4056 e
->ts
.type
= BT_LOGICAL
;
4057 e
->ts
.kind
= gfc_default_logical_kind
;
4059 if (gfc_option
.warn_compare_reals
)
4061 gfc_intrinsic_op op
= e
->value
.op
.op
;
4063 /* Type conversion has made sure that the types of op1 and op2
4064 agree, so it is only necessary to check the first one. */
4065 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4066 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4067 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4071 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4072 msg
= "Equality comparison for %s at %L";
4074 msg
= "Inequality comparison for %s at %L";
4076 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
4083 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4085 _("Logicals at %%L must be compared with %s instead of %s"),
4086 (e
->value
.op
.op
== INTRINSIC_EQ
4087 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4088 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4091 _("Operands of comparison operator '%s' at %%L are %s/%s"),
4092 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4093 gfc_typename (&op2
->ts
));
4097 case INTRINSIC_USER
:
4098 if (e
->value
.op
.uop
->op
== NULL
)
4099 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
4100 else if (op2
== NULL
)
4101 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
4102 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4105 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
4106 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4107 gfc_typename (&op2
->ts
));
4108 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4113 case INTRINSIC_PARENTHESES
:
4115 if (e
->ts
.type
== BT_CHARACTER
)
4116 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4120 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4123 /* Deal with arrayness of an operand through an operator. */
4127 switch (e
->value
.op
.op
)
4129 case INTRINSIC_PLUS
:
4130 case INTRINSIC_MINUS
:
4131 case INTRINSIC_TIMES
:
4132 case INTRINSIC_DIVIDE
:
4133 case INTRINSIC_POWER
:
4134 case INTRINSIC_CONCAT
:
4138 case INTRINSIC_NEQV
:
4140 case INTRINSIC_EQ_OS
:
4142 case INTRINSIC_NE_OS
:
4144 case INTRINSIC_GT_OS
:
4146 case INTRINSIC_GE_OS
:
4148 case INTRINSIC_LT_OS
:
4150 case INTRINSIC_LE_OS
:
4152 if (op1
->rank
== 0 && op2
->rank
== 0)
4155 if (op1
->rank
== 0 && op2
->rank
!= 0)
4157 e
->rank
= op2
->rank
;
4159 if (e
->shape
== NULL
)
4160 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4163 if (op1
->rank
!= 0 && op2
->rank
== 0)
4165 e
->rank
= op1
->rank
;
4167 if (e
->shape
== NULL
)
4168 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4171 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4173 if (op1
->rank
== op2
->rank
)
4175 e
->rank
= op1
->rank
;
4176 if (e
->shape
== NULL
)
4178 t
= compare_shapes (op1
, op2
);
4182 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4187 /* Allow higher level expressions to work. */
4190 /* Try user-defined operators, and otherwise throw an error. */
4191 dual_locus_error
= true;
4193 _("Inconsistent ranks for operator at %%L and %%L"));
4200 case INTRINSIC_PARENTHESES
:
4202 case INTRINSIC_UPLUS
:
4203 case INTRINSIC_UMINUS
:
4204 /* Simply copy arrayness attribute */
4205 e
->rank
= op1
->rank
;
4207 if (e
->shape
== NULL
)
4208 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4216 /* Attempt to simplify the expression. */
4219 t
= gfc_simplify_expr (e
, 0);
4220 /* Some calls do not succeed in simplification and return FAILURE
4221 even though there is no error; e.g. variable references to
4222 PARAMETER arrays. */
4223 if (!gfc_is_constant_expr (e
))
4231 match m
= gfc_extend_expr (e
);
4234 if (m
== MATCH_ERROR
)
4238 if (dual_locus_error
)
4239 gfc_error (msg
, &op1
->where
, &op2
->where
);
4241 gfc_error (msg
, &e
->where
);
4247 /************** Array resolution subroutines **************/
4250 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4253 /* Compare two integer expressions. */
4256 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4260 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4261 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4264 /* If either of the types isn't INTEGER, we must have
4265 raised an error earlier. */
4267 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4270 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4280 /* Compare an integer expression with an integer. */
4283 compare_bound_int (gfc_expr
*a
, int b
)
4287 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4290 if (a
->ts
.type
!= BT_INTEGER
)
4291 gfc_internal_error ("compare_bound_int(): Bad expression");
4293 i
= mpz_cmp_si (a
->value
.integer
, b
);
4303 /* Compare an integer expression with a mpz_t. */
4306 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4310 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4313 if (a
->ts
.type
!= BT_INTEGER
)
4314 gfc_internal_error ("compare_bound_int(): Bad expression");
4316 i
= mpz_cmp (a
->value
.integer
, b
);
4326 /* Compute the last value of a sequence given by a triplet.
4327 Return 0 if it wasn't able to compute the last value, or if the
4328 sequence if empty, and 1 otherwise. */
4331 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4332 gfc_expr
*stride
, mpz_t last
)
4336 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4337 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4338 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4341 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4342 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4345 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4347 if (compare_bound (start
, end
) == CMP_GT
)
4349 mpz_set (last
, end
->value
.integer
);
4353 if (compare_bound_int (stride
, 0) == CMP_GT
)
4355 /* Stride is positive */
4356 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4361 /* Stride is negative */
4362 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4367 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4368 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4369 mpz_sub (last
, end
->value
.integer
, rem
);
4376 /* Compare a single dimension of an array reference to the array
4380 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4384 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4386 gcc_assert (ar
->stride
[i
] == NULL
);
4387 /* This implies [*] as [*:] and [*:3] are not possible. */
4388 if (ar
->start
[i
] == NULL
)
4390 gcc_assert (ar
->end
[i
] == NULL
);
4395 /* Given start, end and stride values, calculate the minimum and
4396 maximum referenced indexes. */
4398 switch (ar
->dimen_type
[i
])
4401 case DIMEN_THIS_IMAGE
:
4406 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4409 gfc_warning ("Array reference at %L is out of bounds "
4410 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4411 mpz_get_si (ar
->start
[i
]->value
.integer
),
4412 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4414 gfc_warning ("Array reference at %L is out of bounds "
4415 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4416 mpz_get_si (ar
->start
[i
]->value
.integer
),
4417 mpz_get_si (as
->lower
[i
]->value
.integer
),
4421 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4424 gfc_warning ("Array reference at %L is out of bounds "
4425 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4426 mpz_get_si (ar
->start
[i
]->value
.integer
),
4427 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4429 gfc_warning ("Array reference at %L is out of bounds "
4430 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4431 mpz_get_si (ar
->start
[i
]->value
.integer
),
4432 mpz_get_si (as
->upper
[i
]->value
.integer
),
4441 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4442 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4444 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4446 /* Check for zero stride, which is not allowed. */
4447 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4449 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4453 /* if start == len || (stride > 0 && start < len)
4454 || (stride < 0 && start > len),
4455 then the array section contains at least one element. In this
4456 case, there is an out-of-bounds access if
4457 (start < lower || start > upper). */
4458 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4459 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4460 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4461 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4462 && comp_start_end
== CMP_GT
))
4464 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4466 gfc_warning ("Lower array reference at %L is out of bounds "
4467 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4468 mpz_get_si (AR_START
->value
.integer
),
4469 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4472 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4474 gfc_warning ("Lower array reference at %L is out of bounds "
4475 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4476 mpz_get_si (AR_START
->value
.integer
),
4477 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4482 /* If we can compute the highest index of the array section,
4483 then it also has to be between lower and upper. */
4484 mpz_init (last_value
);
4485 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4488 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4490 gfc_warning ("Upper array reference at %L is out of bounds "
4491 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4492 mpz_get_si (last_value
),
4493 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4494 mpz_clear (last_value
);
4497 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4499 gfc_warning ("Upper array reference at %L is out of bounds "
4500 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4501 mpz_get_si (last_value
),
4502 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4503 mpz_clear (last_value
);
4507 mpz_clear (last_value
);
4515 gfc_internal_error ("check_dimension(): Bad array reference");
4522 /* Compare an array reference with an array specification. */
4525 compare_spec_to_ref (gfc_array_ref
*ar
)
4532 /* TODO: Full array sections are only allowed as actual parameters. */
4533 if (as
->type
== AS_ASSUMED_SIZE
4534 && (/*ar->type == AR_FULL
4535 ||*/ (ar
->type
== AR_SECTION
4536 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4538 gfc_error ("Rightmost upper bound of assumed size array section "
4539 "not specified at %L", &ar
->where
);
4543 if (ar
->type
== AR_FULL
)
4546 if (as
->rank
!= ar
->dimen
)
4548 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4549 &ar
->where
, ar
->dimen
, as
->rank
);
4553 /* ar->codimen == 0 is a local array. */
4554 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4556 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4557 &ar
->where
, ar
->codimen
, as
->corank
);
4561 for (i
= 0; i
< as
->rank
; i
++)
4562 if (check_dimension (i
, ar
, as
) == FAILURE
)
4565 /* Local access has no coarray spec. */
4566 if (ar
->codimen
!= 0)
4567 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4569 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4570 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4572 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4573 i
+ 1 - as
->rank
, &ar
->where
);
4576 if (check_dimension (i
, ar
, as
) == FAILURE
)
4584 /* Resolve one part of an array index. */
4587 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4588 int force_index_integer_kind
)
4595 if (gfc_resolve_expr (index
) == FAILURE
)
4598 if (check_scalar
&& index
->rank
!= 0)
4600 gfc_error ("Array index at %L must be scalar", &index
->where
);
4604 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4606 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4607 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4611 if (index
->ts
.type
== BT_REAL
)
4612 if (gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4613 &index
->where
) == FAILURE
)
4616 if ((index
->ts
.kind
!= gfc_index_integer_kind
4617 && force_index_integer_kind
)
4618 || index
->ts
.type
!= BT_INTEGER
)
4621 ts
.type
= BT_INTEGER
;
4622 ts
.kind
= gfc_index_integer_kind
;
4624 gfc_convert_type_warn (index
, &ts
, 2, 0);
4630 /* Resolve one part of an array index. */
4633 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4635 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4638 /* Resolve a dim argument to an intrinsic function. */
4641 gfc_resolve_dim_arg (gfc_expr
*dim
)
4646 if (gfc_resolve_expr (dim
) == FAILURE
)
4651 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4656 if (dim
->ts
.type
!= BT_INTEGER
)
4658 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4662 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4667 ts
.type
= BT_INTEGER
;
4668 ts
.kind
= gfc_index_integer_kind
;
4670 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4676 /* Given an expression that contains array references, update those array
4677 references to point to the right array specifications. While this is
4678 filled in during matching, this information is difficult to save and load
4679 in a module, so we take care of it here.
4681 The idea here is that the original array reference comes from the
4682 base symbol. We traverse the list of reference structures, setting
4683 the stored reference to references. Component references can
4684 provide an additional array specification. */
4687 find_array_spec (gfc_expr
*e
)
4693 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4694 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4696 as
= e
->symtree
->n
.sym
->as
;
4698 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4703 gfc_internal_error ("find_array_spec(): Missing spec");
4710 c
= ref
->u
.c
.component
;
4711 if (c
->attr
.dimension
)
4714 gfc_internal_error ("find_array_spec(): unused as(1)");
4725 gfc_internal_error ("find_array_spec(): unused as(2)");
4729 /* Resolve an array reference. */
4732 resolve_array_ref (gfc_array_ref
*ar
)
4734 int i
, check_scalar
;
4737 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4739 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4741 /* Do not force gfc_index_integer_kind for the start. We can
4742 do fine with any integer kind. This avoids temporary arrays
4743 created for indexing with a vector. */
4744 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4746 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4748 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4753 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4757 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4761 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4762 if (e
->expr_type
== EXPR_VARIABLE
4763 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4764 ar
->start
[i
] = gfc_get_parentheses (e
);
4768 gfc_error ("Array index at %L is an array of rank %d",
4769 &ar
->c_where
[i
], e
->rank
);
4773 /* Fill in the upper bound, which may be lower than the
4774 specified one for something like a(2:10:5), which is
4775 identical to a(2:7:5). Only relevant for strides not equal
4776 to one. Don't try a division by zero. */
4777 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4778 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4779 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4780 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4784 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4786 if (ar
->end
[i
] == NULL
)
4789 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4791 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4793 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4794 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4796 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4807 if (ar
->type
== AR_FULL
)
4809 if (ar
->as
->rank
== 0)
4810 ar
->type
= AR_ELEMENT
;
4812 /* Make sure array is the same as array(:,:), this way
4813 we don't need to special case all the time. */
4814 ar
->dimen
= ar
->as
->rank
;
4815 for (i
= 0; i
< ar
->dimen
; i
++)
4817 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4819 gcc_assert (ar
->start
[i
] == NULL
);
4820 gcc_assert (ar
->end
[i
] == NULL
);
4821 gcc_assert (ar
->stride
[i
] == NULL
);
4825 /* If the reference type is unknown, figure out what kind it is. */
4827 if (ar
->type
== AR_UNKNOWN
)
4829 ar
->type
= AR_ELEMENT
;
4830 for (i
= 0; i
< ar
->dimen
; i
++)
4831 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4832 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4834 ar
->type
= AR_SECTION
;
4839 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4842 if (ar
->as
->corank
&& ar
->codimen
== 0)
4845 ar
->codimen
= ar
->as
->corank
;
4846 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4847 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4855 resolve_substring (gfc_ref
*ref
)
4857 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4859 if (ref
->u
.ss
.start
!= NULL
)
4861 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4864 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4866 gfc_error ("Substring start index at %L must be of type INTEGER",
4867 &ref
->u
.ss
.start
->where
);
4871 if (ref
->u
.ss
.start
->rank
!= 0)
4873 gfc_error ("Substring start index at %L must be scalar",
4874 &ref
->u
.ss
.start
->where
);
4878 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4879 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4880 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4882 gfc_error ("Substring start index at %L is less than one",
4883 &ref
->u
.ss
.start
->where
);
4888 if (ref
->u
.ss
.end
!= NULL
)
4890 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4893 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4895 gfc_error ("Substring end index at %L must be of type INTEGER",
4896 &ref
->u
.ss
.end
->where
);
4900 if (ref
->u
.ss
.end
->rank
!= 0)
4902 gfc_error ("Substring end index at %L must be scalar",
4903 &ref
->u
.ss
.end
->where
);
4907 if (ref
->u
.ss
.length
!= NULL
4908 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4909 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4910 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4912 gfc_error ("Substring end index at %L exceeds the string length",
4913 &ref
->u
.ss
.start
->where
);
4917 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4918 gfc_integer_kinds
[k
].huge
) == CMP_GT
4919 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4920 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4922 gfc_error ("Substring end index at %L is too large",
4923 &ref
->u
.ss
.end
->where
);
4932 /* This function supplies missing substring charlens. */
4935 gfc_resolve_substring_charlen (gfc_expr
*e
)
4938 gfc_expr
*start
, *end
;
4940 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4941 if (char_ref
->type
== REF_SUBSTRING
)
4947 gcc_assert (char_ref
->next
== NULL
);
4951 if (e
->ts
.u
.cl
->length
)
4952 gfc_free_expr (e
->ts
.u
.cl
->length
);
4953 else if (e
->expr_type
== EXPR_VARIABLE
4954 && e
->symtree
->n
.sym
->attr
.dummy
)
4958 e
->ts
.type
= BT_CHARACTER
;
4959 e
->ts
.kind
= gfc_default_character_kind
;
4962 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4964 if (char_ref
->u
.ss
.start
)
4965 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4967 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4969 if (char_ref
->u
.ss
.end
)
4970 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4971 else if (e
->expr_type
== EXPR_VARIABLE
)
4972 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4978 gfc_free_expr (start
);
4979 gfc_free_expr (end
);
4983 /* Length = (end - start +1). */
4984 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4985 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4986 gfc_get_int_expr (gfc_default_integer_kind
,
4989 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4990 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4992 /* Make sure that the length is simplified. */
4993 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4994 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4998 /* Resolve subtype references. */
5001 resolve_ref (gfc_expr
*expr
)
5003 int current_part_dimension
, n_components
, seen_part_dimension
;
5006 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5007 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
5009 find_array_spec (expr
);
5013 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5017 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
5025 if (resolve_substring (ref
) == FAILURE
)
5030 /* Check constraints on part references. */
5032 current_part_dimension
= 0;
5033 seen_part_dimension
= 0;
5036 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5041 switch (ref
->u
.ar
.type
)
5044 /* Coarray scalar. */
5045 if (ref
->u
.ar
.as
->rank
== 0)
5047 current_part_dimension
= 0;
5052 current_part_dimension
= 1;
5056 current_part_dimension
= 0;
5060 gfc_internal_error ("resolve_ref(): Bad array reference");
5066 if (current_part_dimension
|| seen_part_dimension
)
5069 if (ref
->u
.c
.component
->attr
.pointer
5070 || ref
->u
.c
.component
->attr
.proc_pointer
5071 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5072 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5074 gfc_error ("Component to the right of a part reference "
5075 "with nonzero rank must not have the POINTER "
5076 "attribute at %L", &expr
->where
);
5079 else if (ref
->u
.c
.component
->attr
.allocatable
5080 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5081 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5084 gfc_error ("Component to the right of a part reference "
5085 "with nonzero rank must not have the ALLOCATABLE "
5086 "attribute at %L", &expr
->where
);
5098 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5099 || ref
->next
== NULL
)
5100 && current_part_dimension
5101 && seen_part_dimension
)
5103 gfc_error ("Two or more part references with nonzero rank must "
5104 "not be specified at %L", &expr
->where
);
5108 if (ref
->type
== REF_COMPONENT
)
5110 if (current_part_dimension
)
5111 seen_part_dimension
= 1;
5113 /* reset to make sure */
5114 current_part_dimension
= 0;
5122 /* Given an expression, determine its shape. This is easier than it sounds.
5123 Leaves the shape array NULL if it is not possible to determine the shape. */
5126 expression_shape (gfc_expr
*e
)
5128 mpz_t array
[GFC_MAX_DIMENSIONS
];
5131 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5134 for (i
= 0; i
< e
->rank
; i
++)
5135 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
5138 e
->shape
= gfc_get_shape (e
->rank
);
5140 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5145 for (i
--; i
>= 0; i
--)
5146 mpz_clear (array
[i
]);
5150 /* Given a variable expression node, compute the rank of the expression by
5151 examining the base symbol and any reference structures it may have. */
5154 expression_rank (gfc_expr
*e
)
5159 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5160 could lead to serious confusion... */
5161 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5165 if (e
->expr_type
== EXPR_ARRAY
)
5167 /* Constructors can have a rank different from one via RESHAPE(). */
5169 if (e
->symtree
== NULL
)
5175 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5176 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5182 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5184 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5185 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5186 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5188 if (ref
->type
!= REF_ARRAY
)
5191 if (ref
->u
.ar
.type
== AR_FULL
)
5193 rank
= ref
->u
.ar
.as
->rank
;
5197 if (ref
->u
.ar
.type
== AR_SECTION
)
5199 /* Figure out the rank of the section. */
5201 gfc_internal_error ("expression_rank(): Two array specs");
5203 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5204 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5205 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5215 expression_shape (e
);
5219 /* Resolve a variable expression. */
5222 resolve_variable (gfc_expr
*e
)
5229 if (e
->symtree
== NULL
)
5231 sym
= e
->symtree
->n
.sym
;
5233 /* TS 29113, 407b. */
5234 if (e
->ts
.type
== BT_ASSUMED
)
5238 gfc_error ("Assumed-type variable %s at %L may only be used "
5239 "as actual argument", sym
->name
, &e
->where
);
5242 else if (inquiry_argument
&& !first_actual_arg
)
5244 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5245 for all inquiry functions in resolve_function; the reason is
5246 that the function-name resolution happens too late in that
5248 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5249 "an inquiry function shall be the first argument",
5250 sym
->name
, &e
->where
);
5255 /* TS 29113, C535b. */
5256 if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5257 && CLASS_DATA (sym
)->as
5258 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5259 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5260 && sym
->as
->type
== AS_ASSUMED_RANK
))
5264 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5265 "actual argument", sym
->name
, &e
->where
);
5268 else if (inquiry_argument
&& !first_actual_arg
)
5270 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5271 for all inquiry functions in resolve_function; the reason is
5272 that the function-name resolution happens too late in that
5274 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5275 "to an inquiry function shall be the first argument",
5276 sym
->name
, &e
->where
);
5281 /* TS 29113, 407b. */
5282 if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5283 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5284 && e
->ref
->next
== NULL
))
5286 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5287 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5291 /* TS 29113, C535b. */
5292 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5293 && CLASS_DATA (sym
)->as
5294 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5295 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5296 && sym
->as
->type
== AS_ASSUMED_RANK
))
5298 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5299 && e
->ref
->next
== NULL
))
5301 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5302 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5307 /* If this is an associate-name, it may be parsed with an array reference
5308 in error even though the target is scalar. Fail directly in this case.
5309 TODO Understand why class scalar expressions must be excluded. */
5310 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5312 if (sym
->ts
.type
== BT_CLASS
)
5313 gfc_fix_class_refs (e
);
5314 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5318 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5319 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5321 /* On the other hand, the parser may not have known this is an array;
5322 in this case, we have to add a FULL reference. */
5323 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5325 e
->ref
= gfc_get_ref ();
5326 e
->ref
->type
= REF_ARRAY
;
5327 e
->ref
->u
.ar
.type
= AR_FULL
;
5328 e
->ref
->u
.ar
.dimen
= 0;
5331 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5334 if (sym
->attr
.flavor
== FL_PROCEDURE
5335 && (!sym
->attr
.function
5336 || (sym
->attr
.function
&& sym
->result
5337 && sym
->result
->attr
.proc_pointer
5338 && !sym
->result
->attr
.function
)))
5340 e
->ts
.type
= BT_PROCEDURE
;
5341 goto resolve_procedure
;
5344 if (sym
->ts
.type
!= BT_UNKNOWN
)
5345 gfc_variable_attr (e
, &e
->ts
);
5348 /* Must be a simple variable reference. */
5349 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5354 if (check_assumed_size_reference (sym
, e
))
5357 /* If a PRIVATE variable is used in the specification expression of the
5358 result variable, it might be accessed from outside the module and can
5359 thus not be TREE_PUBLIC() = 0.
5360 TODO: sym->attr.public_used only has to be set for the result variable's
5361 type-parameter expression and not for dummies or automatic variables.
5362 Additionally, it only has to be set if the function is either PUBLIC or
5363 used in a generic interface or TBP; unfortunately,
5364 proc_name->attr.public_used can get set at a later stage. */
5365 if (specification_expr
&& sym
->attr
.access
== ACCESS_PRIVATE
5366 && !sym
->attr
.function
&& !sym
->attr
.use_assoc
5367 && gfc_current_ns
->proc_name
&& gfc_current_ns
->proc_name
->attr
.function
)
5368 sym
->attr
.public_used
= 1;
5370 /* Deal with forward references to entries during resolve_code, to
5371 satisfy, at least partially, 12.5.2.5. */
5372 if (gfc_current_ns
->entries
5373 && current_entry_id
== sym
->entry_id
5376 && cs_base
->current
->op
!= EXEC_ENTRY
)
5378 gfc_entry_list
*entry
;
5379 gfc_formal_arglist
*formal
;
5381 bool seen
, saved_specification_expr
;
5383 /* If the symbol is a dummy... */
5384 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5386 entry
= gfc_current_ns
->entries
;
5389 /* ...test if the symbol is a parameter of previous entries. */
5390 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5391 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5393 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5397 /* If it has not been seen as a dummy, this is an error. */
5400 if (specification_expr
)
5401 gfc_error ("Variable '%s', used in a specification expression"
5402 ", is referenced at %L before the ENTRY statement "
5403 "in which it is a parameter",
5404 sym
->name
, &cs_base
->current
->loc
);
5406 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5407 "statement in which it is a parameter",
5408 sym
->name
, &cs_base
->current
->loc
);
5413 /* Now do the same check on the specification expressions. */
5414 saved_specification_expr
= specification_expr
;
5415 specification_expr
= true;
5416 if (sym
->ts
.type
== BT_CHARACTER
5417 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5421 for (n
= 0; n
< sym
->as
->rank
; n
++)
5423 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5425 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5428 specification_expr
= saved_specification_expr
;
5431 /* Update the symbol's entry level. */
5432 sym
->entry_id
= current_entry_id
+ 1;
5435 /* If a symbol has been host_associated mark it. This is used latter,
5436 to identify if aliasing is possible via host association. */
5437 if (sym
->attr
.flavor
== FL_VARIABLE
5438 && gfc_current_ns
->parent
5439 && (gfc_current_ns
->parent
== sym
->ns
5440 || (gfc_current_ns
->parent
->parent
5441 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5442 sym
->attr
.host_assoc
= 1;
5445 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5448 /* F2008, C617 and C1229. */
5449 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5450 && gfc_is_coindexed (e
))
5452 gfc_ref
*ref
, *ref2
= NULL
;
5454 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5456 if (ref
->type
== REF_COMPONENT
)
5458 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5462 for ( ; ref
; ref
= ref
->next
)
5463 if (ref
->type
== REF_COMPONENT
)
5466 /* Expression itself is not coindexed object. */
5467 if (ref
&& e
->ts
.type
== BT_CLASS
)
5469 gfc_error ("Polymorphic subobject of coindexed object at %L",
5474 /* Expression itself is coindexed object. */
5478 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5479 for ( ; c
; c
= c
->next
)
5480 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5482 gfc_error ("Coindexed object with polymorphic allocatable "
5483 "subcomponent at %L", &e
->where
);
5494 /* Checks to see that the correct symbol has been host associated.
5495 The only situation where this arises is that in which a twice
5496 contained function is parsed after the host association is made.
5497 Therefore, on detecting this, change the symbol in the expression
5498 and convert the array reference into an actual arglist if the old
5499 symbol is a variable. */
5501 check_host_association (gfc_expr
*e
)
5503 gfc_symbol
*sym
, *old_sym
;
5507 gfc_actual_arglist
*arg
, *tail
= NULL
;
5508 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5510 /* If the expression is the result of substitution in
5511 interface.c(gfc_extend_expr) because there is no way in
5512 which the host association can be wrong. */
5513 if (e
->symtree
== NULL
5514 || e
->symtree
->n
.sym
== NULL
5515 || e
->user_operator
)
5518 old_sym
= e
->symtree
->n
.sym
;
5520 if (gfc_current_ns
->parent
5521 && old_sym
->ns
!= gfc_current_ns
)
5523 /* Use the 'USE' name so that renamed module symbols are
5524 correctly handled. */
5525 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5527 if (sym
&& old_sym
!= sym
5528 && sym
->ts
.type
== old_sym
->ts
.type
5529 && sym
->attr
.flavor
== FL_PROCEDURE
5530 && sym
->attr
.contained
)
5532 /* Clear the shape, since it might not be valid. */
5533 gfc_free_shape (&e
->shape
, e
->rank
);
5535 /* Give the expression the right symtree! */
5536 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5537 gcc_assert (st
!= NULL
);
5539 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5540 || e
->expr_type
== EXPR_FUNCTION
)
5542 /* Original was function so point to the new symbol, since
5543 the actual argument list is already attached to the
5545 e
->value
.function
.esym
= NULL
;
5550 /* Original was variable so convert array references into
5551 an actual arglist. This does not need any checking now
5552 since resolve_function will take care of it. */
5553 e
->value
.function
.actual
= NULL
;
5554 e
->expr_type
= EXPR_FUNCTION
;
5557 /* Ambiguity will not arise if the array reference is not
5558 the last reference. */
5559 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5560 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5563 gcc_assert (ref
->type
== REF_ARRAY
);
5565 /* Grab the start expressions from the array ref and
5566 copy them into actual arguments. */
5567 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5569 arg
= gfc_get_actual_arglist ();
5570 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5571 if (e
->value
.function
.actual
== NULL
)
5572 tail
= e
->value
.function
.actual
= arg
;
5580 /* Dump the reference list and set the rank. */
5581 gfc_free_ref_list (e
->ref
);
5583 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5586 gfc_resolve_expr (e
);
5590 /* This might have changed! */
5591 return e
->expr_type
== EXPR_FUNCTION
;
5596 gfc_resolve_character_operator (gfc_expr
*e
)
5598 gfc_expr
*op1
= e
->value
.op
.op1
;
5599 gfc_expr
*op2
= e
->value
.op
.op2
;
5600 gfc_expr
*e1
= NULL
;
5601 gfc_expr
*e2
= NULL
;
5603 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5605 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5606 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5607 else if (op1
->expr_type
== EXPR_CONSTANT
)
5608 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5609 op1
->value
.character
.length
);
5611 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5612 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5613 else if (op2
->expr_type
== EXPR_CONSTANT
)
5614 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5615 op2
->value
.character
.length
);
5617 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5627 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5628 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5629 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5630 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5631 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5637 /* Ensure that an character expression has a charlen and, if possible, a
5638 length expression. */
5641 fixup_charlen (gfc_expr
*e
)
5643 /* The cases fall through so that changes in expression type and the need
5644 for multiple fixes are picked up. In all circumstances, a charlen should
5645 be available for the middle end to hang a backend_decl on. */
5646 switch (e
->expr_type
)
5649 gfc_resolve_character_operator (e
);
5652 if (e
->expr_type
== EXPR_ARRAY
)
5653 gfc_resolve_character_array_constructor (e
);
5655 case EXPR_SUBSTRING
:
5656 if (!e
->ts
.u
.cl
&& e
->ref
)
5657 gfc_resolve_substring_charlen (e
);
5661 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5668 /* Update an actual argument to include the passed-object for type-bound
5669 procedures at the right position. */
5671 static gfc_actual_arglist
*
5672 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5675 gcc_assert (argpos
> 0);
5679 gfc_actual_arglist
* result
;
5681 result
= gfc_get_actual_arglist ();
5685 result
->name
= name
;
5691 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5693 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5698 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5701 extract_compcall_passed_object (gfc_expr
* e
)
5705 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5707 if (e
->value
.compcall
.base_object
)
5708 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5711 po
= gfc_get_expr ();
5712 po
->expr_type
= EXPR_VARIABLE
;
5713 po
->symtree
= e
->symtree
;
5714 po
->ref
= gfc_copy_ref (e
->ref
);
5715 po
->where
= e
->where
;
5718 if (gfc_resolve_expr (po
) == FAILURE
)
5725 /* Update the arglist of an EXPR_COMPCALL expression to include the
5729 update_compcall_arglist (gfc_expr
* e
)
5732 gfc_typebound_proc
* tbp
;
5734 tbp
= e
->value
.compcall
.tbp
;
5739 po
= extract_compcall_passed_object (e
);
5743 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5749 gcc_assert (tbp
->pass_arg_num
> 0);
5750 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5758 /* Extract the passed object from a PPC call (a copy of it). */
5761 extract_ppc_passed_object (gfc_expr
*e
)
5766 po
= gfc_get_expr ();
5767 po
->expr_type
= EXPR_VARIABLE
;
5768 po
->symtree
= e
->symtree
;
5769 po
->ref
= gfc_copy_ref (e
->ref
);
5770 po
->where
= e
->where
;
5772 /* Remove PPC reference. */
5774 while ((*ref
)->next
)
5775 ref
= &(*ref
)->next
;
5776 gfc_free_ref_list (*ref
);
5779 if (gfc_resolve_expr (po
) == FAILURE
)
5786 /* Update the actual arglist of a procedure pointer component to include the
5790 update_ppc_arglist (gfc_expr
* e
)
5794 gfc_typebound_proc
* tb
;
5796 ppc
= gfc_get_proc_ptr_comp (e
);
5804 else if (tb
->nopass
)
5807 po
= extract_ppc_passed_object (e
);
5814 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5819 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5821 gfc_error ("Base object for procedure-pointer component call at %L is of"
5822 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5826 gcc_assert (tb
->pass_arg_num
> 0);
5827 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5835 /* Check that the object a TBP is called on is valid, i.e. it must not be
5836 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5839 check_typebound_baseobject (gfc_expr
* e
)
5842 gfc_try return_value
= FAILURE
;
5844 base
= extract_compcall_passed_object (e
);
5848 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5850 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5854 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5856 gfc_error ("Base object for type-bound procedure call at %L is of"
5857 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5861 /* F08:C1230. If the procedure called is NOPASS,
5862 the base object must be scalar. */
5863 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5865 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5866 " be scalar", &e
->where
);
5870 return_value
= SUCCESS
;
5873 gfc_free_expr (base
);
5874 return return_value
;
5878 /* Resolve a call to a type-bound procedure, either function or subroutine,
5879 statically from the data in an EXPR_COMPCALL expression. The adapted
5880 arglist and the target-procedure symtree are returned. */
5883 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5884 gfc_actual_arglist
** actual
)
5886 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5887 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5889 /* Update the actual arglist for PASS. */
5890 if (update_compcall_arglist (e
) == FAILURE
)
5893 *actual
= e
->value
.compcall
.actual
;
5894 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5896 gfc_free_ref_list (e
->ref
);
5898 e
->value
.compcall
.actual
= NULL
;
5900 /* If we find a deferred typebound procedure, check for derived types
5901 that an overriding typebound procedure has not been missed. */
5902 if (e
->value
.compcall
.name
5903 && !e
->value
.compcall
.tbp
->non_overridable
5904 && e
->value
.compcall
.base_object
5905 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5908 gfc_symbol
*derived
;
5910 /* Use the derived type of the base_object. */
5911 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5914 /* If necessary, go through the inheritance chain. */
5915 while (!st
&& derived
)
5917 /* Look for the typebound procedure 'name'. */
5918 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5919 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5920 e
->value
.compcall
.name
);
5922 derived
= gfc_get_derived_super_type (derived
);
5925 /* Now find the specific name in the derived type namespace. */
5926 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5927 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5928 derived
->ns
, 1, &st
);
5936 /* Get the ultimate declared type from an expression. In addition,
5937 return the last class/derived type reference and the copy of the
5938 reference list. If check_types is set true, derived types are
5939 identified as well as class references. */
5941 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5942 gfc_expr
*e
, bool check_types
)
5944 gfc_symbol
*declared
;
5951 *new_ref
= gfc_copy_ref (e
->ref
);
5953 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5955 if (ref
->type
!= REF_COMPONENT
)
5958 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5959 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5960 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5962 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5968 if (declared
== NULL
)
5969 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5975 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5976 which of the specific bindings (if any) matches the arglist and transform
5977 the expression into a call of that binding. */
5980 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5982 gfc_typebound_proc
* genproc
;
5983 const char* genname
;
5985 gfc_symbol
*derived
;
5987 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5988 genname
= e
->value
.compcall
.name
;
5989 genproc
= e
->value
.compcall
.tbp
;
5991 if (!genproc
->is_generic
)
5994 /* Try the bindings on this type and in the inheritance hierarchy. */
5995 for (; genproc
; genproc
= genproc
->overridden
)
5999 gcc_assert (genproc
->is_generic
);
6000 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
6003 gfc_actual_arglist
* args
;
6006 gcc_assert (g
->specific
);
6008 if (g
->specific
->error
)
6011 target
= g
->specific
->u
.specific
->n
.sym
;
6013 /* Get the right arglist by handling PASS/NOPASS. */
6014 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
6015 if (!g
->specific
->nopass
)
6018 po
= extract_compcall_passed_object (e
);
6021 gfc_free_actual_arglist (args
);
6025 gcc_assert (g
->specific
->pass_arg_num
> 0);
6026 gcc_assert (!g
->specific
->error
);
6027 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6028 g
->specific
->pass_arg
);
6030 resolve_actual_arglist (args
, target
->attr
.proc
,
6031 is_external_proc (target
) && !target
->formal
);
6033 /* Check if this arglist matches the formal. */
6034 matches
= gfc_arglist_matches_symbol (&args
, target
);
6036 /* Clean up and break out of the loop if we've found it. */
6037 gfc_free_actual_arglist (args
);
6040 e
->value
.compcall
.tbp
= g
->specific
;
6041 genname
= g
->specific_st
->name
;
6042 /* Pass along the name for CLASS methods, where the vtab
6043 procedure pointer component has to be referenced. */
6051 /* Nothing matching found! */
6052 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6053 " '%s' at %L", genname
, &e
->where
);
6057 /* Make sure that we have the right specific instance for the name. */
6058 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6060 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6062 e
->value
.compcall
.tbp
= st
->n
.tb
;
6068 /* Resolve a call to a type-bound subroutine. */
6071 resolve_typebound_call (gfc_code
* c
, const char **name
)
6073 gfc_actual_arglist
* newactual
;
6074 gfc_symtree
* target
;
6076 /* Check that's really a SUBROUTINE. */
6077 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6079 gfc_error ("'%s' at %L should be a SUBROUTINE",
6080 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6084 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
6087 /* Pass along the name for CLASS methods, where the vtab
6088 procedure pointer component has to be referenced. */
6090 *name
= c
->expr1
->value
.compcall
.name
;
6092 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
6095 /* Transform into an ordinary EXEC_CALL for now. */
6097 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
6100 c
->ext
.actual
= newactual
;
6101 c
->symtree
= target
;
6102 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6104 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6106 gfc_free_expr (c
->expr1
);
6107 c
->expr1
= gfc_get_expr ();
6108 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6109 c
->expr1
->symtree
= target
;
6110 c
->expr1
->where
= c
->loc
;
6112 return resolve_call (c
);
6116 /* Resolve a component-call expression. */
6118 resolve_compcall (gfc_expr
* e
, const char **name
)
6120 gfc_actual_arglist
* newactual
;
6121 gfc_symtree
* target
;
6123 /* Check that's really a FUNCTION. */
6124 if (!e
->value
.compcall
.tbp
->function
)
6126 gfc_error ("'%s' at %L should be a FUNCTION",
6127 e
->value
.compcall
.name
, &e
->where
);
6131 /* These must not be assign-calls! */
6132 gcc_assert (!e
->value
.compcall
.assign
);
6134 if (check_typebound_baseobject (e
) == FAILURE
)
6137 /* Pass along the name for CLASS methods, where the vtab
6138 procedure pointer component has to be referenced. */
6140 *name
= e
->value
.compcall
.name
;
6142 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
6144 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6146 /* Take the rank from the function's symbol. */
6147 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6148 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6150 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6151 arglist to the TBP's binding target. */
6153 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
6156 e
->value
.function
.actual
= newactual
;
6157 e
->value
.function
.name
= NULL
;
6158 e
->value
.function
.esym
= target
->n
.sym
;
6159 e
->value
.function
.isym
= NULL
;
6160 e
->symtree
= target
;
6161 e
->ts
= target
->n
.sym
->ts
;
6162 e
->expr_type
= EXPR_FUNCTION
;
6164 /* Resolution is not necessary if this is a class subroutine; this
6165 function only has to identify the specific proc. Resolution of
6166 the call will be done next in resolve_typebound_call. */
6167 return gfc_resolve_expr (e
);
6172 /* Resolve a typebound function, or 'method'. First separate all
6173 the non-CLASS references by calling resolve_compcall directly. */
6176 resolve_typebound_function (gfc_expr
* e
)
6178 gfc_symbol
*declared
;
6190 /* Deal with typebound operators for CLASS objects. */
6191 expr
= e
->value
.compcall
.base_object
;
6192 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6193 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6195 /* If the base_object is not a variable, the corresponding actual
6196 argument expression must be stored in e->base_expression so
6197 that the corresponding tree temporary can be used as the base
6198 object in gfc_conv_procedure_call. */
6199 if (expr
->expr_type
!= EXPR_VARIABLE
)
6201 gfc_actual_arglist
*args
;
6203 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6205 if (expr
== args
->expr
)
6210 /* Since the typebound operators are generic, we have to ensure
6211 that any delays in resolution are corrected and that the vtab
6214 declared
= ts
.u
.derived
;
6215 c
= gfc_find_component (declared
, "_vptr", true, true);
6216 if (c
->ts
.u
.derived
== NULL
)
6217 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6219 if (resolve_compcall (e
, &name
) == FAILURE
)
6222 /* Use the generic name if it is there. */
6223 name
= name
? name
: e
->value
.function
.esym
->name
;
6224 e
->symtree
= expr
->symtree
;
6225 e
->ref
= gfc_copy_ref (expr
->ref
);
6226 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6228 /* Trim away the extraneous references that emerge from nested
6229 use of interface.c (extend_expr). */
6230 if (class_ref
&& class_ref
->next
)
6232 gfc_free_ref_list (class_ref
->next
);
6233 class_ref
->next
= NULL
;
6235 else if (e
->ref
&& !class_ref
)
6237 gfc_free_ref_list (e
->ref
);
6241 gfc_add_vptr_component (e
);
6242 gfc_add_component_ref (e
, name
);
6243 e
->value
.function
.esym
= NULL
;
6244 if (expr
->expr_type
!= EXPR_VARIABLE
)
6245 e
->base_expr
= expr
;
6250 return resolve_compcall (e
, NULL
);
6252 if (resolve_ref (e
) == FAILURE
)
6255 /* Get the CLASS declared type. */
6256 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6258 /* Weed out cases of the ultimate component being a derived type. */
6259 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6260 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6262 gfc_free_ref_list (new_ref
);
6263 return resolve_compcall (e
, NULL
);
6266 c
= gfc_find_component (declared
, "_data", true, true);
6267 declared
= c
->ts
.u
.derived
;
6269 /* Treat the call as if it is a typebound procedure, in order to roll
6270 out the correct name for the specific function. */
6271 if (resolve_compcall (e
, &name
) == FAILURE
)
6273 gfc_free_ref_list (new_ref
);
6280 /* Convert the expression to a procedure pointer component call. */
6281 e
->value
.function
.esym
= NULL
;
6287 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6288 gfc_add_vptr_component (e
);
6289 gfc_add_component_ref (e
, name
);
6291 /* Recover the typespec for the expression. This is really only
6292 necessary for generic procedures, where the additional call
6293 to gfc_add_component_ref seems to throw the collection of the
6294 correct typespec. */
6301 /* Resolve a typebound subroutine, or 'method'. First separate all
6302 the non-CLASS references by calling resolve_typebound_call
6306 resolve_typebound_subroutine (gfc_code
*code
)
6308 gfc_symbol
*declared
;
6318 st
= code
->expr1
->symtree
;
6320 /* Deal with typebound operators for CLASS objects. */
6321 expr
= code
->expr1
->value
.compcall
.base_object
;
6322 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6323 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6325 /* If the base_object is not a variable, the corresponding actual
6326 argument expression must be stored in e->base_expression so
6327 that the corresponding tree temporary can be used as the base
6328 object in gfc_conv_procedure_call. */
6329 if (expr
->expr_type
!= EXPR_VARIABLE
)
6331 gfc_actual_arglist
*args
;
6333 args
= code
->expr1
->value
.function
.actual
;
6334 for (; args
; args
= args
->next
)
6335 if (expr
== args
->expr
)
6339 /* Since the typebound operators are generic, we have to ensure
6340 that any delays in resolution are corrected and that the vtab
6342 declared
= expr
->ts
.u
.derived
;
6343 c
= gfc_find_component (declared
, "_vptr", true, true);
6344 if (c
->ts
.u
.derived
== NULL
)
6345 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6347 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6350 /* Use the generic name if it is there. */
6351 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6352 code
->expr1
->symtree
= expr
->symtree
;
6353 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6355 /* Trim away the extraneous references that emerge from nested
6356 use of interface.c (extend_expr). */
6357 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6358 if (class_ref
&& class_ref
->next
)
6360 gfc_free_ref_list (class_ref
->next
);
6361 class_ref
->next
= NULL
;
6363 else if (code
->expr1
->ref
&& !class_ref
)
6365 gfc_free_ref_list (code
->expr1
->ref
);
6366 code
->expr1
->ref
= NULL
;
6369 /* Now use the procedure in the vtable. */
6370 gfc_add_vptr_component (code
->expr1
);
6371 gfc_add_component_ref (code
->expr1
, name
);
6372 code
->expr1
->value
.function
.esym
= NULL
;
6373 if (expr
->expr_type
!= EXPR_VARIABLE
)
6374 code
->expr1
->base_expr
= expr
;
6379 return resolve_typebound_call (code
, NULL
);
6381 if (resolve_ref (code
->expr1
) == FAILURE
)
6384 /* Get the CLASS declared type. */
6385 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6387 /* Weed out cases of the ultimate component being a derived type. */
6388 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6389 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6391 gfc_free_ref_list (new_ref
);
6392 return resolve_typebound_call (code
, NULL
);
6395 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6397 gfc_free_ref_list (new_ref
);
6400 ts
= code
->expr1
->ts
;
6404 /* Convert the expression to a procedure pointer component call. */
6405 code
->expr1
->value
.function
.esym
= NULL
;
6406 code
->expr1
->symtree
= st
;
6409 code
->expr1
->ref
= new_ref
;
6411 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6412 gfc_add_vptr_component (code
->expr1
);
6413 gfc_add_component_ref (code
->expr1
, name
);
6415 /* Recover the typespec for the expression. This is really only
6416 necessary for generic procedures, where the additional call
6417 to gfc_add_component_ref seems to throw the collection of the
6418 correct typespec. */
6419 code
->expr1
->ts
= ts
;
6426 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6429 resolve_ppc_call (gfc_code
* c
)
6431 gfc_component
*comp
;
6433 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6434 gcc_assert (comp
!= NULL
);
6436 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6437 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6439 if (!comp
->attr
.subroutine
)
6440 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6442 if (resolve_ref (c
->expr1
) == FAILURE
)
6445 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6448 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6450 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6451 comp
->formal
== NULL
) == FAILURE
)
6454 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6460 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6463 resolve_expr_ppc (gfc_expr
* e
)
6465 gfc_component
*comp
;
6467 comp
= gfc_get_proc_ptr_comp (e
);
6468 gcc_assert (comp
!= NULL
);
6470 /* Convert to EXPR_FUNCTION. */
6471 e
->expr_type
= EXPR_FUNCTION
;
6472 e
->value
.function
.isym
= NULL
;
6473 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6475 if (comp
->as
!= NULL
)
6476 e
->rank
= comp
->as
->rank
;
6478 if (!comp
->attr
.function
)
6479 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6481 if (resolve_ref (e
) == FAILURE
)
6484 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6485 comp
->formal
== NULL
) == FAILURE
)
6488 if (update_ppc_arglist (e
) == FAILURE
)
6491 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6498 gfc_is_expandable_expr (gfc_expr
*e
)
6500 gfc_constructor
*con
;
6502 if (e
->expr_type
== EXPR_ARRAY
)
6504 /* Traverse the constructor looking for variables that are flavor
6505 parameter. Parameters must be expanded since they are fully used at
6507 con
= gfc_constructor_first (e
->value
.constructor
);
6508 for (; con
; con
= gfc_constructor_next (con
))
6510 if (con
->expr
->expr_type
== EXPR_VARIABLE
6511 && con
->expr
->symtree
6512 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6513 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6515 if (con
->expr
->expr_type
== EXPR_ARRAY
6516 && gfc_is_expandable_expr (con
->expr
))
6524 /* Resolve an expression. That is, make sure that types of operands agree
6525 with their operators, intrinsic operators are converted to function calls
6526 for overloaded types and unresolved function references are resolved. */
6529 gfc_resolve_expr (gfc_expr
*e
)
6532 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6537 /* inquiry_argument only applies to variables. */
6538 inquiry_save
= inquiry_argument
;
6539 actual_arg_save
= actual_arg
;
6540 first_actual_arg_save
= first_actual_arg
;
6542 if (e
->expr_type
!= EXPR_VARIABLE
)
6544 inquiry_argument
= false;
6546 first_actual_arg
= false;
6549 switch (e
->expr_type
)
6552 t
= resolve_operator (e
);
6558 if (check_host_association (e
))
6559 t
= resolve_function (e
);
6562 t
= resolve_variable (e
);
6564 expression_rank (e
);
6567 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6568 && e
->ref
->type
!= REF_SUBSTRING
)
6569 gfc_resolve_substring_charlen (e
);
6574 t
= resolve_typebound_function (e
);
6577 case EXPR_SUBSTRING
:
6578 t
= resolve_ref (e
);
6587 t
= resolve_expr_ppc (e
);
6592 if (resolve_ref (e
) == FAILURE
)
6595 t
= gfc_resolve_array_constructor (e
);
6596 /* Also try to expand a constructor. */
6599 expression_rank (e
);
6600 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6601 gfc_expand_constructor (e
, false);
6604 /* This provides the opportunity for the length of constructors with
6605 character valued function elements to propagate the string length
6606 to the expression. */
6607 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6609 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6610 here rather then add a duplicate test for it above. */
6611 gfc_expand_constructor (e
, false);
6612 t
= gfc_resolve_character_array_constructor (e
);
6617 case EXPR_STRUCTURE
:
6618 t
= resolve_ref (e
);
6622 t
= resolve_structure_cons (e
, 0);
6626 t
= gfc_simplify_expr (e
, 0);
6630 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6633 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6636 inquiry_argument
= inquiry_save
;
6637 actual_arg
= actual_arg_save
;
6638 first_actual_arg
= first_actual_arg_save
;
6644 /* Resolve an expression from an iterator. They must be scalar and have
6645 INTEGER or (optionally) REAL type. */
6648 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6649 const char *name_msgid
)
6651 if (gfc_resolve_expr (expr
) == FAILURE
)
6654 if (expr
->rank
!= 0)
6656 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6660 if (expr
->ts
.type
!= BT_INTEGER
)
6662 if (expr
->ts
.type
== BT_REAL
)
6665 return gfc_notify_std (GFC_STD_F95_DEL
,
6666 "%s at %L must be integer",
6667 _(name_msgid
), &expr
->where
);
6670 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6677 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6685 /* Resolve the expressions in an iterator structure. If REAL_OK is
6686 false allow only INTEGER type iterators, otherwise allow REAL types.
6687 Set own_scope to true for ac-implied-do and data-implied-do as those
6688 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */
6691 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
, bool own_scope
)
6693 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6697 if (gfc_check_vardef_context (iter
->var
, false, false, own_scope
,
6698 _("iterator variable"))
6702 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6703 "Start expression in DO loop") == FAILURE
)
6706 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6707 "End expression in DO loop") == FAILURE
)
6710 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6711 "Step expression in DO loop") == FAILURE
)
6714 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6716 if ((iter
->step
->ts
.type
== BT_INTEGER
6717 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6718 || (iter
->step
->ts
.type
== BT_REAL
6719 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6721 gfc_error ("Step expression in DO loop at %L cannot be zero",
6722 &iter
->step
->where
);
6727 /* Convert start, end, and step to the same type as var. */
6728 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6729 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6730 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6732 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6733 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6734 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6736 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6737 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6738 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6740 if (iter
->start
->expr_type
== EXPR_CONSTANT
6741 && iter
->end
->expr_type
== EXPR_CONSTANT
6742 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6745 if (iter
->start
->ts
.type
== BT_INTEGER
)
6747 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6748 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6752 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6753 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6755 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6756 gfc_warning ("DO loop at %L will be executed zero times",
6757 &iter
->step
->where
);
6764 /* Traversal function for find_forall_index. f == 2 signals that
6765 that variable itself is not to be checked - only the references. */
6768 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6770 if (expr
->expr_type
!= EXPR_VARIABLE
)
6773 /* A scalar assignment */
6774 if (!expr
->ref
|| *f
== 1)
6776 if (expr
->symtree
->n
.sym
== sym
)
6788 /* Check whether the FORALL index appears in the expression or not.
6789 Returns SUCCESS if SYM is found in EXPR. */
6792 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6794 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6801 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6802 to be a scalar INTEGER variable. The subscripts and stride are scalar
6803 INTEGERs, and if stride is a constant it must be nonzero.
6804 Furthermore "A subscript or stride in a forall-triplet-spec shall
6805 not contain a reference to any index-name in the
6806 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6809 resolve_forall_iterators (gfc_forall_iterator
*it
)
6811 gfc_forall_iterator
*iter
, *iter2
;
6813 for (iter
= it
; iter
; iter
= iter
->next
)
6815 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6816 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6817 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6820 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6821 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6822 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6823 &iter
->start
->where
);
6824 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6825 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6827 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6828 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6829 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6831 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6832 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6834 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6836 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6837 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6838 &iter
->stride
->where
, "INTEGER");
6840 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6841 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6842 gfc_error ("FORALL stride expression at %L cannot be zero",
6843 &iter
->stride
->where
);
6845 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6846 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6849 for (iter
= it
; iter
; iter
= iter
->next
)
6850 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6852 if (find_forall_index (iter2
->start
,
6853 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6854 || find_forall_index (iter2
->end
,
6855 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6856 || find_forall_index (iter2
->stride
,
6857 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6858 gfc_error ("FORALL index '%s' may not appear in triplet "
6859 "specification at %L", iter
->var
->symtree
->name
,
6860 &iter2
->start
->where
);
6865 /* Given a pointer to a symbol that is a derived type, see if it's
6866 inaccessible, i.e. if it's defined in another module and the components are
6867 PRIVATE. The search is recursive if necessary. Returns zero if no
6868 inaccessible components are found, nonzero otherwise. */
6871 derived_inaccessible (gfc_symbol
*sym
)
6875 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6878 for (c
= sym
->components
; c
; c
= c
->next
)
6880 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6888 /* Resolve the argument of a deallocate expression. The expression must be
6889 a pointer or a full array. */
6892 resolve_deallocate_expr (gfc_expr
*e
)
6894 symbol_attribute attr
;
6895 int allocatable
, pointer
;
6900 if (gfc_resolve_expr (e
) == FAILURE
)
6903 if (e
->expr_type
!= EXPR_VARIABLE
)
6906 sym
= e
->symtree
->n
.sym
;
6908 if (sym
->ts
.type
== BT_CLASS
)
6910 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6911 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6915 allocatable
= sym
->attr
.allocatable
;
6916 pointer
= sym
->attr
.pointer
;
6918 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6923 if (ref
->u
.ar
.type
!= AR_FULL
6924 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6925 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6930 c
= ref
->u
.c
.component
;
6931 if (c
->ts
.type
== BT_CLASS
)
6933 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6934 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6938 allocatable
= c
->attr
.allocatable
;
6939 pointer
= c
->attr
.pointer
;
6949 attr
= gfc_expr_attr (e
);
6951 if (allocatable
== 0 && attr
.pointer
== 0)
6954 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6960 if (gfc_is_coindexed (e
))
6962 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6967 && gfc_check_vardef_context (e
, true, true, false, _("DEALLOCATE object"))
6970 if (gfc_check_vardef_context (e
, false, true, false, _("DEALLOCATE object"))
6978 /* Returns true if the expression e contains a reference to the symbol sym. */
6980 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6982 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6989 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6991 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6995 /* Given the expression node e for an allocatable/pointer of derived type to be
6996 allocated, get the expression node to be initialized afterwards (needed for
6997 derived types with default initializers, and derived types with allocatable
6998 components that need nullification.) */
7001 gfc_expr_to_initialize (gfc_expr
*e
)
7007 result
= gfc_copy_expr (e
);
7009 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
7010 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
7011 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
7013 ref
->u
.ar
.type
= AR_FULL
;
7015 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
7016 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
7021 gfc_free_shape (&result
->shape
, result
->rank
);
7023 /* Recalculate rank, shape, etc. */
7024 gfc_resolve_expr (result
);
7029 /* If the last ref of an expression is an array ref, return a copy of the
7030 expression with that one removed. Otherwise, a copy of the original
7031 expression. This is used for allocate-expressions and pointer assignment
7032 LHS, where there may be an array specification that needs to be stripped
7033 off when using gfc_check_vardef_context. */
7036 remove_last_array_ref (gfc_expr
* e
)
7041 e2
= gfc_copy_expr (e
);
7042 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7043 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7045 gfc_free_ref_list (*r
);
7054 /* Used in resolve_allocate_expr to check that a allocation-object and
7055 a source-expr are conformable. This does not catch all possible
7056 cases; in particular a runtime checking is needed. */
7059 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7062 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7064 /* First compare rank. */
7065 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7067 gfc_error ("Source-expr at %L must be scalar or have the "
7068 "same rank as the allocate-object at %L",
7069 &e1
->where
, &e2
->where
);
7080 for (i
= 0; i
< e1
->rank
; i
++)
7082 if (tail
->u
.ar
.end
[i
])
7084 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7085 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7086 mpz_add_ui (s
, s
, 1);
7090 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7093 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7095 gfc_error ("Source-expr at %L and allocate-object at %L must "
7096 "have the same shape", &e1
->where
, &e2
->where
);
7109 /* Resolve the expression in an ALLOCATE statement, doing the additional
7110 checks to see whether the expression is OK or not. The expression must
7111 have a trailing array reference that gives the size of the array. */
7114 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
7116 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7119 symbol_attribute attr
;
7120 gfc_ref
*ref
, *ref2
;
7123 gfc_symbol
*sym
= NULL
;
7128 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7129 checking of coarrays. */
7130 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7131 if (ref
->next
== NULL
)
7134 if (ref
&& ref
->type
== REF_ARRAY
)
7135 ref
->u
.ar
.in_allocate
= true;
7137 if (gfc_resolve_expr (e
) == FAILURE
)
7140 /* Make sure the expression is allocatable or a pointer. If it is
7141 pointer, the next-to-last reference must be a pointer. */
7145 sym
= e
->symtree
->n
.sym
;
7147 /* Check whether ultimate component is abstract and CLASS. */
7150 if (e
->expr_type
!= EXPR_VARIABLE
)
7153 attr
= gfc_expr_attr (e
);
7154 pointer
= attr
.pointer
;
7155 dimension
= attr
.dimension
;
7156 codimension
= attr
.codimension
;
7160 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7162 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7163 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7164 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7165 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7166 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7170 allocatable
= sym
->attr
.allocatable
;
7171 pointer
= sym
->attr
.pointer
;
7172 dimension
= sym
->attr
.dimension
;
7173 codimension
= sym
->attr
.codimension
;
7178 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7183 if (ref
->u
.ar
.codimen
> 0)
7186 for (n
= ref
->u
.ar
.dimen
;
7187 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7188 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7195 if (ref
->next
!= NULL
)
7203 gfc_error ("Coindexed allocatable object at %L",
7208 c
= ref
->u
.c
.component
;
7209 if (c
->ts
.type
== BT_CLASS
)
7211 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7212 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7213 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7214 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7215 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7219 allocatable
= c
->attr
.allocatable
;
7220 pointer
= c
->attr
.pointer
;
7221 dimension
= c
->attr
.dimension
;
7222 codimension
= c
->attr
.codimension
;
7223 is_abstract
= c
->attr
.abstract
;
7235 /* Check for F08:C628. */
7236 if (allocatable
== 0 && pointer
== 0)
7238 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7243 /* Some checks for the SOURCE tag. */
7246 /* Check F03:C631. */
7247 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7249 gfc_error ("Type of entity at %L is type incompatible with "
7250 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7254 /* Check F03:C632 and restriction following Note 6.18. */
7255 if (code
->expr3
->rank
> 0
7256 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
7259 /* Check F03:C633. */
7260 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
7262 gfc_error ("The allocate-object at %L and the source-expr at %L "
7263 "shall have the same kind type parameter",
7264 &e
->where
, &code
->expr3
->where
);
7268 /* Check F2008, C642. */
7269 if (code
->expr3
->ts
.type
== BT_DERIVED
7270 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7271 || (code
->expr3
->ts
.u
.derived
->from_intmod
7272 == INTMOD_ISO_FORTRAN_ENV
7273 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7274 == ISOFORTRAN_LOCK_TYPE
)))
7276 gfc_error ("The source-expr at %L shall neither be of type "
7277 "LOCK_TYPE nor have a LOCK_TYPE component if "
7278 "allocate-object at %L is a coarray",
7279 &code
->expr3
->where
, &e
->where
);
7284 /* Check F08:C629. */
7285 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7288 gcc_assert (e
->ts
.type
== BT_CLASS
);
7289 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7290 "type-spec or source-expr", sym
->name
, &e
->where
);
7294 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
7296 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7297 code
->ext
.alloc
.ts
.u
.cl
->length
);
7298 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7300 gfc_error ("Allocating %s at %L with type-spec requires the same "
7301 "character-length parameter as in the declaration",
7302 sym
->name
, &e
->where
);
7307 /* In the variable definition context checks, gfc_expr_attr is used
7308 on the expression. This is fooled by the array specification
7309 present in e, thus we have to eliminate that one temporarily. */
7310 e2
= remove_last_array_ref (e
);
7312 if (t
== SUCCESS
&& pointer
)
7313 t
= gfc_check_vardef_context (e2
, true, true, false, _("ALLOCATE object"));
7315 t
= gfc_check_vardef_context (e2
, false, true, false, _("ALLOCATE object"));
7320 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7321 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7323 /* For class arrays, the initialization with SOURCE is done
7324 using _copy and trans_call. It is convenient to exploit that
7325 when the allocated type is different from the declared type but
7326 no SOURCE exists by setting expr3. */
7327 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7329 else if (!code
->expr3
)
7331 /* Set up default initializer if needed. */
7335 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7336 ts
= code
->ext
.alloc
.ts
;
7340 if (ts
.type
== BT_CLASS
)
7341 ts
= ts
.u
.derived
->components
->ts
;
7343 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7345 gfc_code
*init_st
= gfc_get_code ();
7346 init_st
->loc
= code
->loc
;
7347 init_st
->op
= EXEC_INIT_ASSIGN
;
7348 init_st
->expr1
= gfc_expr_to_initialize (e
);
7349 init_st
->expr2
= init_e
;
7350 init_st
->next
= code
->next
;
7351 code
->next
= init_st
;
7354 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7356 /* Default initialization via MOLD (non-polymorphic). */
7357 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7358 gfc_resolve_expr (rhs
);
7359 gfc_free_expr (code
->expr3
);
7363 if (e
->ts
.type
== BT_CLASS
)
7365 /* Make sure the vtab symbol is present when
7366 the module variables are generated. */
7367 gfc_typespec ts
= e
->ts
;
7369 ts
= code
->expr3
->ts
;
7370 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7371 ts
= code
->ext
.alloc
.ts
;
7372 gfc_find_derived_vtab (ts
.u
.derived
);
7374 e
= gfc_expr_to_initialize (e
);
7377 if (dimension
== 0 && codimension
== 0)
7380 /* Make sure the last reference node is an array specification. */
7382 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7383 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7385 gfc_error ("Array specification required in ALLOCATE statement "
7386 "at %L", &e
->where
);
7390 /* Make sure that the array section reference makes sense in the
7391 context of an ALLOCATE specification. */
7396 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7397 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7399 gfc_error ("Coarray specification required in ALLOCATE statement "
7400 "at %L", &e
->where
);
7404 for (i
= 0; i
< ar
->dimen
; i
++)
7406 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7409 switch (ar
->dimen_type
[i
])
7415 if (ar
->start
[i
] != NULL
7416 && ar
->end
[i
] != NULL
7417 && ar
->stride
[i
] == NULL
)
7420 /* Fall Through... */
7425 case DIMEN_THIS_IMAGE
:
7426 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7432 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7434 sym
= a
->expr
->symtree
->n
.sym
;
7436 /* TODO - check derived type components. */
7437 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7440 if ((ar
->start
[i
] != NULL
7441 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7442 || (ar
->end
[i
] != NULL
7443 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7445 gfc_error ("'%s' must not appear in the array specification at "
7446 "%L in the same ALLOCATE statement where it is "
7447 "itself allocated", sym
->name
, &ar
->where
);
7453 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7455 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7456 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7458 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7460 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7461 "statement at %L", &e
->where
);
7467 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7468 && ar
->stride
[i
] == NULL
)
7471 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7484 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7486 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7487 gfc_alloc
*a
, *p
, *q
;
7490 errmsg
= code
->expr2
;
7492 /* Check the stat variable. */
7495 gfc_check_vardef_context (stat
, false, false, false, _("STAT variable"));
7497 if ((stat
->ts
.type
!= BT_INTEGER
7498 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7499 || stat
->ref
->type
== REF_COMPONENT
)))
7501 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7502 "variable", &stat
->where
);
7504 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7505 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7507 gfc_ref
*ref1
, *ref2
;
7510 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7511 ref1
= ref1
->next
, ref2
= ref2
->next
)
7513 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7515 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7524 gfc_error ("Stat-variable at %L shall not be %sd within "
7525 "the same %s statement", &stat
->where
, fcn
, fcn
);
7531 /* Check the errmsg variable. */
7535 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7538 gfc_check_vardef_context (errmsg
, false, false, false,
7539 _("ERRMSG variable"));
7541 if ((errmsg
->ts
.type
!= BT_CHARACTER
7543 && (errmsg
->ref
->type
== REF_ARRAY
7544 || errmsg
->ref
->type
== REF_COMPONENT
)))
7545 || errmsg
->rank
> 0 )
7546 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7547 "variable", &errmsg
->where
);
7549 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7550 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7552 gfc_ref
*ref1
, *ref2
;
7555 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7556 ref1
= ref1
->next
, ref2
= ref2
->next
)
7558 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7560 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7569 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7570 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7576 /* Check that an allocate-object appears only once in the statement. */
7578 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7581 for (q
= p
->next
; q
; q
= q
->next
)
7584 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7586 /* This is a potential collision. */
7587 gfc_ref
*pr
= pe
->ref
;
7588 gfc_ref
*qr
= qe
->ref
;
7590 /* Follow the references until
7591 a) They start to differ, in which case there is no error;
7592 you can deallocate a%b and a%c in a single statement
7593 b) Both of them stop, which is an error
7594 c) One of them stops, which is also an error. */
7597 if (pr
== NULL
&& qr
== NULL
)
7599 gfc_error ("Allocate-object at %L also appears at %L",
7600 &pe
->where
, &qe
->where
);
7603 else if (pr
!= NULL
&& qr
== NULL
)
7605 gfc_error ("Allocate-object at %L is subobject of"
7606 " object at %L", &pe
->where
, &qe
->where
);
7609 else if (pr
== NULL
&& qr
!= NULL
)
7611 gfc_error ("Allocate-object at %L is subobject of"
7612 " object at %L", &qe
->where
, &pe
->where
);
7615 /* Here, pr != NULL && qr != NULL */
7616 gcc_assert(pr
->type
== qr
->type
);
7617 if (pr
->type
== REF_ARRAY
)
7619 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7621 gcc_assert (qr
->type
== REF_ARRAY
);
7623 if (pr
->next
&& qr
->next
)
7625 gfc_array_ref
*par
= &(pr
->u
.ar
);
7626 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7627 if ((par
->start
[0] != NULL
|| qar
->start
[0] != NULL
)
7628 && gfc_dep_compare_expr (par
->start
[0],
7629 qar
->start
[0]) != 0)
7635 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7646 if (strcmp (fcn
, "ALLOCATE") == 0)
7648 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7649 resolve_allocate_expr (a
->expr
, code
);
7653 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7654 resolve_deallocate_expr (a
->expr
);
7659 /************ SELECT CASE resolution subroutines ************/
7661 /* Callback function for our mergesort variant. Determines interval
7662 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7663 op1 > op2. Assumes we're not dealing with the default case.
7664 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7665 There are nine situations to check. */
7668 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7672 if (op1
->low
== NULL
) /* op1 = (:L) */
7674 /* op2 = (:N), so overlap. */
7676 /* op2 = (M:) or (M:N), L < M */
7677 if (op2
->low
!= NULL
7678 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7681 else if (op1
->high
== NULL
) /* op1 = (K:) */
7683 /* op2 = (M:), so overlap. */
7685 /* op2 = (:N) or (M:N), K > N */
7686 if (op2
->high
!= NULL
7687 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7690 else /* op1 = (K:L) */
7692 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7693 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7695 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7696 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7698 else /* op2 = (M:N) */
7702 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7705 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7714 /* Merge-sort a double linked case list, detecting overlap in the
7715 process. LIST is the head of the double linked case list before it
7716 is sorted. Returns the head of the sorted list if we don't see any
7717 overlap, or NULL otherwise. */
7720 check_case_overlap (gfc_case
*list
)
7722 gfc_case
*p
, *q
, *e
, *tail
;
7723 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7725 /* If the passed list was empty, return immediately. */
7732 /* Loop unconditionally. The only exit from this loop is a return
7733 statement, when we've finished sorting the case list. */
7740 /* Count the number of merges we do in this pass. */
7743 /* Loop while there exists a merge to be done. */
7748 /* Count this merge. */
7751 /* Cut the list in two pieces by stepping INSIZE places
7752 forward in the list, starting from P. */
7755 for (i
= 0; i
< insize
; i
++)
7764 /* Now we have two lists. Merge them! */
7765 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7767 /* See from which the next case to merge comes from. */
7770 /* P is empty so the next case must come from Q. */
7775 else if (qsize
== 0 || q
== NULL
)
7784 cmp
= compare_cases (p
, q
);
7787 /* The whole case range for P is less than the
7795 /* The whole case range for Q is greater than
7796 the case range for P. */
7803 /* The cases overlap, or they are the same
7804 element in the list. Either way, we must
7805 issue an error and get the next case from P. */
7806 /* FIXME: Sort P and Q by line number. */
7807 gfc_error ("CASE label at %L overlaps with CASE "
7808 "label at %L", &p
->where
, &q
->where
);
7816 /* Add the next element to the merged list. */
7825 /* P has now stepped INSIZE places along, and so has Q. So
7826 they're the same. */
7831 /* If we have done only one merge or none at all, we've
7832 finished sorting the cases. */
7841 /* Otherwise repeat, merging lists twice the size. */
7847 /* Check to see if an expression is suitable for use in a CASE statement.
7848 Makes sure that all case expressions are scalar constants of the same
7849 type. Return FAILURE if anything is wrong. */
7852 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7854 if (e
== NULL
) return SUCCESS
;
7856 if (e
->ts
.type
!= case_expr
->ts
.type
)
7858 gfc_error ("Expression in CASE statement at %L must be of type %s",
7859 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7863 /* C805 (R808) For a given case-construct, each case-value shall be of
7864 the same type as case-expr. For character type, length differences
7865 are allowed, but the kind type parameters shall be the same. */
7867 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7869 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7870 &e
->where
, case_expr
->ts
.kind
);
7874 /* Convert the case value kind to that of case expression kind,
7877 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7878 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7882 gfc_error ("Expression in CASE statement at %L must be scalar",
7891 /* Given a completely parsed select statement, we:
7893 - Validate all expressions and code within the SELECT.
7894 - Make sure that the selection expression is not of the wrong type.
7895 - Make sure that no case ranges overlap.
7896 - Eliminate unreachable cases and unreachable code resulting from
7897 removing case labels.
7899 The standard does allow unreachable cases, e.g. CASE (5:3). But
7900 they are a hassle for code generation, and to prevent that, we just
7901 cut them out here. This is not necessary for overlapping cases
7902 because they are illegal and we never even try to generate code.
7904 We have the additional caveat that a SELECT construct could have
7905 been a computed GOTO in the source code. Fortunately we can fairly
7906 easily work around that here: The case_expr for a "real" SELECT CASE
7907 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7908 we have to do is make sure that the case_expr is a scalar integer
7912 resolve_select (gfc_code
*code
)
7915 gfc_expr
*case_expr
;
7916 gfc_case
*cp
, *default_case
, *tail
, *head
;
7917 int seen_unreachable
;
7923 if (code
->expr1
== NULL
)
7925 /* This was actually a computed GOTO statement. */
7926 case_expr
= code
->expr2
;
7927 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7928 gfc_error ("Selection expression in computed GOTO statement "
7929 "at %L must be a scalar integer expression",
7932 /* Further checking is not necessary because this SELECT was built
7933 by the compiler, so it should always be OK. Just move the
7934 case_expr from expr2 to expr so that we can handle computed
7935 GOTOs as normal SELECTs from here on. */
7936 code
->expr1
= code
->expr2
;
7941 case_expr
= code
->expr1
;
7943 type
= case_expr
->ts
.type
;
7944 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7946 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7947 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7949 /* Punt. Going on here just produce more garbage error messages. */
7953 /* Raise a warning if an INTEGER case value exceeds the range of
7954 the case-expr. Later, all expressions will be promoted to the
7955 largest kind of all case-labels. */
7957 if (type
== BT_INTEGER
)
7958 for (body
= code
->block
; body
; body
= body
->block
)
7959 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7962 && gfc_check_integer_range (cp
->low
->value
.integer
,
7963 case_expr
->ts
.kind
) != ARITH_OK
)
7964 gfc_warning ("Expression in CASE statement at %L is "
7965 "not in the range of %s", &cp
->low
->where
,
7966 gfc_typename (&case_expr
->ts
));
7969 && cp
->low
!= cp
->high
7970 && gfc_check_integer_range (cp
->high
->value
.integer
,
7971 case_expr
->ts
.kind
) != ARITH_OK
)
7972 gfc_warning ("Expression in CASE statement at %L is "
7973 "not in the range of %s", &cp
->high
->where
,
7974 gfc_typename (&case_expr
->ts
));
7977 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7978 of the SELECT CASE expression and its CASE values. Walk the lists
7979 of case values, and if we find a mismatch, promote case_expr to
7980 the appropriate kind. */
7982 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7984 for (body
= code
->block
; body
; body
= body
->block
)
7986 /* Walk the case label list. */
7987 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7989 /* Intercept the DEFAULT case. It does not have a kind. */
7990 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7993 /* Unreachable case ranges are discarded, so ignore. */
7994 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7995 && cp
->low
!= cp
->high
7996 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8000 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
8001 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
8003 if (cp
->high
!= NULL
8004 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
8005 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
8010 /* Assume there is no DEFAULT case. */
8011 default_case
= NULL
;
8016 for (body
= code
->block
; body
; body
= body
->block
)
8018 /* Assume the CASE list is OK, and all CASE labels can be matched. */
8020 seen_unreachable
= 0;
8022 /* Walk the case label list, making sure that all case labels
8024 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
8026 /* Count the number of cases in the whole construct. */
8029 /* Intercept the DEFAULT case. */
8030 if (cp
->low
== NULL
&& cp
->high
== NULL
)
8032 if (default_case
!= NULL
)
8034 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8035 "by a second DEFAULT CASE at %L",
8036 &default_case
->where
, &cp
->where
);
8047 /* Deal with single value cases and case ranges. Errors are
8048 issued from the validation function. */
8049 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
8050 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
8056 if (type
== BT_LOGICAL
8057 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8058 || cp
->low
!= cp
->high
))
8060 gfc_error ("Logical range in CASE statement at %L is not "
8061 "allowed", &cp
->low
->where
);
8066 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8069 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8070 if (value
& seen_logical
)
8072 gfc_error ("Constant logical value in CASE statement "
8073 "is repeated at %L",
8078 seen_logical
|= value
;
8081 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8082 && cp
->low
!= cp
->high
8083 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8085 if (gfc_option
.warn_surprising
)
8086 gfc_warning ("Range specification at %L can never "
8087 "be matched", &cp
->where
);
8089 cp
->unreachable
= 1;
8090 seen_unreachable
= 1;
8094 /* If the case range can be matched, it can also overlap with
8095 other cases. To make sure it does not, we put it in a
8096 double linked list here. We sort that with a merge sort
8097 later on to detect any overlapping cases. */
8101 head
->right
= head
->left
= NULL
;
8106 tail
->right
->left
= tail
;
8113 /* It there was a failure in the previous case label, give up
8114 for this case label list. Continue with the next block. */
8118 /* See if any case labels that are unreachable have been seen.
8119 If so, we eliminate them. This is a bit of a kludge because
8120 the case lists for a single case statement (label) is a
8121 single forward linked lists. */
8122 if (seen_unreachable
)
8124 /* Advance until the first case in the list is reachable. */
8125 while (body
->ext
.block
.case_list
!= NULL
8126 && body
->ext
.block
.case_list
->unreachable
)
8128 gfc_case
*n
= body
->ext
.block
.case_list
;
8129 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8131 gfc_free_case_list (n
);
8134 /* Strip all other unreachable cases. */
8135 if (body
->ext
.block
.case_list
)
8137 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
8139 if (cp
->next
->unreachable
)
8141 gfc_case
*n
= cp
->next
;
8142 cp
->next
= cp
->next
->next
;
8144 gfc_free_case_list (n
);
8151 /* See if there were overlapping cases. If the check returns NULL,
8152 there was overlap. In that case we don't do anything. If head
8153 is non-NULL, we prepend the DEFAULT case. The sorted list can
8154 then used during code generation for SELECT CASE constructs with
8155 a case expression of a CHARACTER type. */
8158 head
= check_case_overlap (head
);
8160 /* Prepend the default_case if it is there. */
8161 if (head
!= NULL
&& default_case
)
8163 default_case
->left
= NULL
;
8164 default_case
->right
= head
;
8165 head
->left
= default_case
;
8169 /* Eliminate dead blocks that may be the result if we've seen
8170 unreachable case labels for a block. */
8171 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8173 if (body
->block
->ext
.block
.case_list
== NULL
)
8175 /* Cut the unreachable block from the code chain. */
8176 gfc_code
*c
= body
->block
;
8177 body
->block
= c
->block
;
8179 /* Kill the dead block, but not the blocks below it. */
8181 gfc_free_statements (c
);
8185 /* More than two cases is legal but insane for logical selects.
8186 Issue a warning for it. */
8187 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
8189 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
8194 /* Check if a derived type is extensible. */
8197 gfc_type_is_extensible (gfc_symbol
*sym
)
8199 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
8203 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8204 correct as well as possibly the array-spec. */
8207 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8211 gcc_assert (sym
->assoc
);
8212 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8214 /* If this is for SELECT TYPE, the target may not yet be set. In that
8215 case, return. Resolution will be called later manually again when
8217 target
= sym
->assoc
->target
;
8220 gcc_assert (!sym
->assoc
->dangling
);
8222 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
8225 /* For variable targets, we get some attributes from the target. */
8226 if (target
->expr_type
== EXPR_VARIABLE
)
8230 gcc_assert (target
->symtree
);
8231 tsym
= target
->symtree
->n
.sym
;
8233 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8234 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8236 sym
->attr
.target
= tsym
->attr
.target
8237 || gfc_expr_attr (target
).pointer
;
8240 /* Get type if this was not already set. Note that it can be
8241 some other type than the target in case this is a SELECT TYPE
8242 selector! So we must not update when the type is already there. */
8243 if (sym
->ts
.type
== BT_UNKNOWN
)
8244 sym
->ts
= target
->ts
;
8245 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8247 /* See if this is a valid association-to-variable. */
8248 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8249 && !gfc_has_vector_subscript (target
));
8251 /* Finally resolve if this is an array or not. */
8252 if (sym
->attr
.dimension
&& target
->rank
== 0)
8254 gfc_error ("Associate-name '%s' at %L is used as array",
8255 sym
->name
, &sym
->declared_at
);
8256 sym
->attr
.dimension
= 0;
8260 /* We cannot deal with class selectors that need temporaries. */
8261 if (target
->ts
.type
== BT_CLASS
8262 && gfc_ref_needs_temporary_p (target
->ref
))
8264 gfc_error ("CLASS selector at %L needs a temporary which is not "
8265 "yet implemented", &target
->where
);
8269 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8270 sym
->attr
.dimension
= 1;
8271 else if (target
->ts
.type
== BT_CLASS
)
8272 gfc_fix_class_refs (target
);
8274 /* The associate-name will have a correct type by now. Make absolutely
8275 sure that it has not picked up a dimension attribute. */
8276 if (sym
->ts
.type
== BT_CLASS
)
8277 sym
->attr
.dimension
= 0;
8279 if (sym
->attr
.dimension
)
8281 sym
->as
= gfc_get_array_spec ();
8282 sym
->as
->rank
= target
->rank
;
8283 sym
->as
->type
= AS_DEFERRED
;
8285 /* Target must not be coindexed, thus the associate-variable
8287 sym
->as
->corank
= 0;
8292 /* Resolve a SELECT TYPE statement. */
8295 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8297 gfc_symbol
*selector_type
;
8298 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8299 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8302 char name
[GFC_MAX_SYMBOL_LEN
];
8306 ns
= code
->ext
.block
.ns
;
8309 /* Check for F03:C813. */
8310 if (code
->expr1
->ts
.type
!= BT_CLASS
8311 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8313 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8314 "at %L", &code
->loc
);
8318 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8323 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8324 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8325 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8328 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8330 /* Loop over TYPE IS / CLASS IS cases. */
8331 for (body
= code
->block
; body
; body
= body
->block
)
8333 c
= body
->ext
.block
.case_list
;
8335 /* Check F03:C815. */
8336 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8337 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8339 gfc_error ("Derived type '%s' at %L must be extensible",
8340 c
->ts
.u
.derived
->name
, &c
->where
);
8345 /* Check F03:C816. */
8346 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8347 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
8349 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8350 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8355 /* Intercept the DEFAULT case. */
8356 if (c
->ts
.type
== BT_UNKNOWN
)
8358 /* Check F03:C818. */
8361 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8362 "by a second DEFAULT CASE at %L",
8363 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8368 default_case
= body
;
8375 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8376 target if present. If there are any EXIT statements referring to the
8377 SELECT TYPE construct, this is no problem because the gfc_code
8378 reference stays the same and EXIT is equally possible from the BLOCK
8379 it is changed to. */
8380 code
->op
= EXEC_BLOCK
;
8383 gfc_association_list
* assoc
;
8385 assoc
= gfc_get_association_list ();
8386 assoc
->st
= code
->expr1
->symtree
;
8387 assoc
->target
= gfc_copy_expr (code
->expr2
);
8388 assoc
->target
->where
= code
->expr2
->where
;
8389 /* assoc->variable will be set by resolve_assoc_var. */
8391 code
->ext
.block
.assoc
= assoc
;
8392 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8394 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8397 code
->ext
.block
.assoc
= NULL
;
8399 /* Add EXEC_SELECT to switch on type. */
8400 new_st
= gfc_get_code ();
8401 new_st
->op
= code
->op
;
8402 new_st
->expr1
= code
->expr1
;
8403 new_st
->expr2
= code
->expr2
;
8404 new_st
->block
= code
->block
;
8405 code
->expr1
= code
->expr2
= NULL
;
8410 ns
->code
->next
= new_st
;
8412 code
->op
= EXEC_SELECT
;
8413 gfc_add_vptr_component (code
->expr1
);
8414 gfc_add_hash_component (code
->expr1
);
8416 /* Loop over TYPE IS / CLASS IS cases. */
8417 for (body
= code
->block
; body
; body
= body
->block
)
8419 c
= body
->ext
.block
.case_list
;
8421 if (c
->ts
.type
== BT_DERIVED
)
8422 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8423 c
->ts
.u
.derived
->hash_value
);
8425 else if (c
->ts
.type
== BT_UNKNOWN
)
8428 /* Associate temporary to selector. This should only be done
8429 when this case is actually true, so build a new ASSOCIATE
8430 that does precisely this here (instead of using the
8433 if (c
->ts
.type
== BT_CLASS
)
8434 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8436 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8437 st
= gfc_find_symtree (ns
->sym_root
, name
);
8438 gcc_assert (st
->n
.sym
->assoc
);
8439 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8440 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8441 if (c
->ts
.type
== BT_DERIVED
)
8442 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8444 new_st
= gfc_get_code ();
8445 new_st
->op
= EXEC_BLOCK
;
8446 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8447 new_st
->ext
.block
.ns
->code
= body
->next
;
8448 body
->next
= new_st
;
8450 /* Chain in the new list only if it is marked as dangling. Otherwise
8451 there is a CASE label overlap and this is already used. Just ignore,
8452 the error is diagnosed elsewhere. */
8453 if (st
->n
.sym
->assoc
->dangling
)
8455 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8456 st
->n
.sym
->assoc
->dangling
= 0;
8459 resolve_assoc_var (st
->n
.sym
, false);
8462 /* Take out CLASS IS cases for separate treatment. */
8464 while (body
&& body
->block
)
8466 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8468 /* Add to class_is list. */
8469 if (class_is
== NULL
)
8471 class_is
= body
->block
;
8476 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8477 tail
->block
= body
->block
;
8480 /* Remove from EXEC_SELECT list. */
8481 body
->block
= body
->block
->block
;
8494 /* Add a default case to hold the CLASS IS cases. */
8495 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8496 tail
->block
= gfc_get_code ();
8498 tail
->op
= EXEC_SELECT_TYPE
;
8499 tail
->ext
.block
.case_list
= gfc_get_case ();
8500 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8502 default_case
= tail
;
8505 /* More than one CLASS IS block? */
8506 if (class_is
->block
)
8510 /* Sort CLASS IS blocks by extension level. */
8514 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8517 /* F03:C817 (check for doubles). */
8518 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8519 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8521 gfc_error ("Double CLASS IS block in SELECT TYPE "
8523 &c2
->ext
.block
.case_list
->where
);
8526 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8527 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8530 (*c1
)->block
= c2
->block
;
8540 /* Generate IF chain. */
8541 if_st
= gfc_get_code ();
8542 if_st
->op
= EXEC_IF
;
8544 for (body
= class_is
; body
; body
= body
->block
)
8546 new_st
->block
= gfc_get_code ();
8547 new_st
= new_st
->block
;
8548 new_st
->op
= EXEC_IF
;
8549 /* Set up IF condition: Call _gfortran_is_extension_of. */
8550 new_st
->expr1
= gfc_get_expr ();
8551 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8552 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8553 new_st
->expr1
->ts
.kind
= 4;
8554 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8555 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8556 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8557 /* Set up arguments. */
8558 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8559 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8560 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8561 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8562 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8563 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8564 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8565 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8566 new_st
->next
= body
->next
;
8568 if (default_case
->next
)
8570 new_st
->block
= gfc_get_code ();
8571 new_st
= new_st
->block
;
8572 new_st
->op
= EXEC_IF
;
8573 new_st
->next
= default_case
->next
;
8576 /* Replace CLASS DEFAULT code by the IF chain. */
8577 default_case
->next
= if_st
;
8580 /* Resolve the internal code. This can not be done earlier because
8581 it requires that the sym->assoc of selectors is set already. */
8582 gfc_current_ns
= ns
;
8583 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8584 gfc_current_ns
= old_ns
;
8586 resolve_select (code
);
8590 /* Resolve a transfer statement. This is making sure that:
8591 -- a derived type being transferred has only non-pointer components
8592 -- a derived type being transferred doesn't have private components, unless
8593 it's being transferred from the module where the type was defined
8594 -- we're not trying to transfer a whole assumed size array. */
8597 resolve_transfer (gfc_code
*code
)
8606 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8607 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8608 exp
= exp
->value
.op
.op1
;
8610 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8612 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8613 "MOLD=", &exp
->where
);
8617 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8618 && exp
->expr_type
!= EXPR_FUNCTION
))
8621 /* If we are reading, the variable will be changed. Note that
8622 code->ext.dt may be NULL if the TRANSFER is related to
8623 an INQUIRE statement -- but in this case, we are not reading, either. */
8624 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8625 && gfc_check_vardef_context (exp
, false, false, false, _("item in READ"))
8629 sym
= exp
->symtree
->n
.sym
;
8632 /* Go to actual component transferred. */
8633 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8634 if (ref
->type
== REF_COMPONENT
)
8635 ts
= &ref
->u
.c
.component
->ts
;
8637 if (ts
->type
== BT_CLASS
)
8639 /* FIXME: Test for defined input/output. */
8640 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8641 "it is processed by a defined input/output procedure",
8646 if (ts
->type
== BT_DERIVED
)
8648 /* Check that transferred derived type doesn't contain POINTER
8650 if (ts
->u
.derived
->attr
.pointer_comp
)
8652 gfc_error ("Data transfer element at %L cannot have POINTER "
8653 "components unless it is processed by a defined "
8654 "input/output procedure", &code
->loc
);
8659 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8661 gfc_error ("Data transfer element at %L cannot have "
8662 "procedure pointer components", &code
->loc
);
8666 if (ts
->u
.derived
->attr
.alloc_comp
)
8668 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8669 "components unless it is processed by a defined "
8670 "input/output procedure", &code
->loc
);
8674 if (derived_inaccessible (ts
->u
.derived
))
8676 gfc_error ("Data transfer element at %L cannot have "
8677 "PRIVATE components",&code
->loc
);
8682 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8683 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8685 gfc_error ("Data transfer element at %L cannot be a full reference to "
8686 "an assumed-size array", &code
->loc
);
8692 /*********** Toplevel code resolution subroutines ***********/
8694 /* Find the set of labels that are reachable from this block. We also
8695 record the last statement in each block. */
8698 find_reachable_labels (gfc_code
*block
)
8705 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8707 /* Collect labels in this block. We don't keep those corresponding
8708 to END {IF|SELECT}, these are checked in resolve_branch by going
8709 up through the code_stack. */
8710 for (c
= block
; c
; c
= c
->next
)
8712 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8713 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8716 /* Merge with labels from parent block. */
8719 gcc_assert (cs_base
->prev
->reachable_labels
);
8720 bitmap_ior_into (cs_base
->reachable_labels
,
8721 cs_base
->prev
->reachable_labels
);
8727 resolve_lock_unlock (gfc_code
*code
)
8729 if (code
->expr1
->ts
.type
!= BT_DERIVED
8730 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8731 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8732 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8733 || code
->expr1
->rank
!= 0
8734 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8735 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8736 &code
->expr1
->where
);
8740 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8741 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8742 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8743 &code
->expr2
->where
);
8746 && gfc_check_vardef_context (code
->expr2
, false, false, false,
8747 _("STAT variable")) == FAILURE
)
8752 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8753 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8754 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8755 &code
->expr3
->where
);
8758 && gfc_check_vardef_context (code
->expr3
, false, false, false,
8759 _("ERRMSG variable")) == FAILURE
)
8762 /* Check ACQUIRED_LOCK. */
8764 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8765 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8766 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8767 "variable", &code
->expr4
->where
);
8770 && gfc_check_vardef_context (code
->expr4
, false, false, false,
8771 _("ACQUIRED_LOCK variable")) == FAILURE
)
8777 resolve_sync (gfc_code
*code
)
8779 /* Check imageset. The * case matches expr1 == NULL. */
8782 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8783 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8784 "INTEGER expression", &code
->expr1
->where
);
8785 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8786 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8787 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8788 &code
->expr1
->where
);
8789 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8790 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8792 gfc_constructor
*cons
;
8793 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8794 for (; cons
; cons
= gfc_constructor_next (cons
))
8795 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8796 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8797 gfc_error ("Imageset argument at %L must between 1 and "
8798 "num_images()", &cons
->expr
->where
);
8804 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8805 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8806 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8807 &code
->expr2
->where
);
8811 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8812 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8813 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8814 &code
->expr3
->where
);
8818 /* Given a branch to a label, see if the branch is conforming.
8819 The code node describes where the branch is located. */
8822 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8829 /* Step one: is this a valid branching target? */
8831 if (label
->defined
== ST_LABEL_UNKNOWN
)
8833 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8838 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8840 gfc_error ("Statement at %L is not a valid branch target statement "
8841 "for the branch statement at %L", &label
->where
, &code
->loc
);
8845 /* Step two: make sure this branch is not a branch to itself ;-) */
8847 if (code
->here
== label
)
8849 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8853 /* Step three: See if the label is in the same block as the
8854 branching statement. The hard work has been done by setting up
8855 the bitmap reachable_labels. */
8857 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8859 /* Check now whether there is a CRITICAL construct; if so, check
8860 whether the label is still visible outside of the CRITICAL block,
8861 which is invalid. */
8862 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8864 if (stack
->current
->op
== EXEC_CRITICAL
8865 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8866 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8867 "label at %L", &code
->loc
, &label
->where
);
8868 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8869 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8870 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8871 "for label at %L", &code
->loc
, &label
->where
);
8877 /* Step four: If we haven't found the label in the bitmap, it may
8878 still be the label of the END of the enclosing block, in which
8879 case we find it by going up the code_stack. */
8881 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8883 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8885 if (stack
->current
->op
== EXEC_CRITICAL
)
8887 /* Note: A label at END CRITICAL does not leave the CRITICAL
8888 construct as END CRITICAL is still part of it. */
8889 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8890 " at %L", &code
->loc
, &label
->where
);
8893 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8895 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8896 "label at %L", &code
->loc
, &label
->where
);
8903 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8907 /* The label is not in an enclosing block, so illegal. This was
8908 allowed in Fortran 66, so we allow it as extension. No
8909 further checks are necessary in this case. */
8910 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8911 "as the GOTO statement at %L", &label
->where
,
8917 /* Check whether EXPR1 has the same shape as EXPR2. */
8920 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8922 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8923 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8924 gfc_try result
= FAILURE
;
8927 /* Compare the rank. */
8928 if (expr1
->rank
!= expr2
->rank
)
8931 /* Compare the size of each dimension. */
8932 for (i
=0; i
<expr1
->rank
; i
++)
8934 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8937 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8940 if (mpz_cmp (shape
[i
], shape2
[i
]))
8944 /* When either of the two expression is an assumed size array, we
8945 ignore the comparison of dimension sizes. */
8950 gfc_clear_shape (shape
, i
);
8951 gfc_clear_shape (shape2
, i
);
8956 /* Check whether a WHERE assignment target or a WHERE mask expression
8957 has the same shape as the outmost WHERE mask expression. */
8960 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8966 cblock
= code
->block
;
8968 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8969 In case of nested WHERE, only the outmost one is stored. */
8970 if (mask
== NULL
) /* outmost WHERE */
8972 else /* inner WHERE */
8979 /* Check if the mask-expr has a consistent shape with the
8980 outmost WHERE mask-expr. */
8981 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8982 gfc_error ("WHERE mask at %L has inconsistent shape",
8983 &cblock
->expr1
->where
);
8986 /* the assignment statement of a WHERE statement, or the first
8987 statement in where-body-construct of a WHERE construct */
8988 cnext
= cblock
->next
;
8993 /* WHERE assignment statement */
8996 /* Check shape consistent for WHERE assignment target. */
8997 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8998 gfc_error ("WHERE assignment target at %L has "
8999 "inconsistent shape", &cnext
->expr1
->where
);
9003 case EXEC_ASSIGN_CALL
:
9004 resolve_call (cnext
);
9005 if (!cnext
->resolved_sym
->attr
.elemental
)
9006 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9007 &cnext
->ext
.actual
->expr
->where
);
9010 /* WHERE or WHERE construct is part of a where-body-construct */
9012 resolve_where (cnext
, e
);
9016 gfc_error ("Unsupported statement inside WHERE at %L",
9019 /* the next statement within the same where-body-construct */
9020 cnext
= cnext
->next
;
9022 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9023 cblock
= cblock
->block
;
9028 /* Resolve assignment in FORALL construct.
9029 NVAR is the number of FORALL index variables, and VAR_EXPR records the
9030 FORALL index variables. */
9033 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9037 for (n
= 0; n
< nvar
; n
++)
9039 gfc_symbol
*forall_index
;
9041 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9043 /* Check whether the assignment target is one of the FORALL index
9045 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9046 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9047 gfc_error ("Assignment to a FORALL index variable at %L",
9048 &code
->expr1
->where
);
9051 /* If one of the FORALL index variables doesn't appear in the
9052 assignment variable, then there could be a many-to-one
9053 assignment. Emit a warning rather than an error because the
9054 mask could be resolving this problem. */
9055 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
9056 gfc_warning ("The FORALL with index '%s' is not used on the "
9057 "left side of the assignment at %L and so might "
9058 "cause multiple assignment to this object",
9059 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9065 /* Resolve WHERE statement in FORALL construct. */
9068 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9069 gfc_expr
**var_expr
)
9074 cblock
= code
->block
;
9077 /* the assignment statement of a WHERE statement, or the first
9078 statement in where-body-construct of a WHERE construct */
9079 cnext
= cblock
->next
;
9084 /* WHERE assignment statement */
9086 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9089 /* WHERE operator assignment statement */
9090 case EXEC_ASSIGN_CALL
:
9091 resolve_call (cnext
);
9092 if (!cnext
->resolved_sym
->attr
.elemental
)
9093 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9094 &cnext
->ext
.actual
->expr
->where
);
9097 /* WHERE or WHERE construct is part of a where-body-construct */
9099 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9103 gfc_error ("Unsupported statement inside WHERE at %L",
9106 /* the next statement within the same where-body-construct */
9107 cnext
= cnext
->next
;
9109 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9110 cblock
= cblock
->block
;
9115 /* Traverse the FORALL body to check whether the following errors exist:
9116 1. For assignment, check if a many-to-one assignment happens.
9117 2. For WHERE statement, check the WHERE body to see if there is any
9118 many-to-one assignment. */
9121 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9125 c
= code
->block
->next
;
9131 case EXEC_POINTER_ASSIGN
:
9132 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9135 case EXEC_ASSIGN_CALL
:
9139 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9140 there is no need to handle it here. */
9144 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9149 /* The next statement in the FORALL body. */
9155 /* Counts the number of iterators needed inside a forall construct, including
9156 nested forall constructs. This is used to allocate the needed memory
9157 in gfc_resolve_forall. */
9160 gfc_count_forall_iterators (gfc_code
*code
)
9162 int max_iters
, sub_iters
, current_iters
;
9163 gfc_forall_iterator
*fa
;
9165 gcc_assert(code
->op
== EXEC_FORALL
);
9169 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9172 code
= code
->block
->next
;
9176 if (code
->op
== EXEC_FORALL
)
9178 sub_iters
= gfc_count_forall_iterators (code
);
9179 if (sub_iters
> max_iters
)
9180 max_iters
= sub_iters
;
9185 return current_iters
+ max_iters
;
9189 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9190 gfc_resolve_forall_body to resolve the FORALL body. */
9193 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9195 static gfc_expr
**var_expr
;
9196 static int total_var
= 0;
9197 static int nvar
= 0;
9199 gfc_forall_iterator
*fa
;
9204 /* Start to resolve a FORALL construct */
9205 if (forall_save
== 0)
9207 /* Count the total number of FORALL index in the nested FORALL
9208 construct in order to allocate the VAR_EXPR with proper size. */
9209 total_var
= gfc_count_forall_iterators (code
);
9211 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9212 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9215 /* The information about FORALL iterator, including FORALL index start, end
9216 and stride. The FORALL index can not appear in start, end or stride. */
9217 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9219 /* Check if any outer FORALL index name is the same as the current
9221 for (i
= 0; i
< nvar
; i
++)
9223 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9225 gfc_error ("An outer FORALL construct already has an index "
9226 "with this name %L", &fa
->var
->where
);
9230 /* Record the current FORALL index. */
9231 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9235 /* No memory leak. */
9236 gcc_assert (nvar
<= total_var
);
9239 /* Resolve the FORALL body. */
9240 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9242 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9243 gfc_resolve_blocks (code
->block
, ns
);
9247 /* Free only the VAR_EXPRs allocated in this frame. */
9248 for (i
= nvar
; i
< tmp
; i
++)
9249 gfc_free_expr (var_expr
[i
]);
9253 /* We are in the outermost FORALL construct. */
9254 gcc_assert (forall_save
== 0);
9256 /* VAR_EXPR is not needed any more. */
9263 /* Resolve a BLOCK construct statement. */
9266 resolve_block_construct (gfc_code
* code
)
9268 /* Resolve the BLOCK's namespace. */
9269 gfc_resolve (code
->ext
.block
.ns
);
9271 /* For an ASSOCIATE block, the associations (and their targets) are already
9272 resolved during resolve_symbol. */
9276 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9279 static void resolve_code (gfc_code
*, gfc_namespace
*);
9282 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9286 for (; b
; b
= b
->block
)
9288 t
= gfc_resolve_expr (b
->expr1
);
9289 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
9295 if (t
== SUCCESS
&& b
->expr1
!= NULL
9296 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9297 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9304 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9305 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9310 resolve_branch (b
->label1
, b
);
9314 resolve_block_construct (b
);
9318 case EXEC_SELECT_TYPE
:
9322 case EXEC_DO_CONCURRENT
:
9330 case EXEC_OMP_ATOMIC
:
9331 case EXEC_OMP_CRITICAL
:
9333 case EXEC_OMP_MASTER
:
9334 case EXEC_OMP_ORDERED
:
9335 case EXEC_OMP_PARALLEL
:
9336 case EXEC_OMP_PARALLEL_DO
:
9337 case EXEC_OMP_PARALLEL_SECTIONS
:
9338 case EXEC_OMP_PARALLEL_WORKSHARE
:
9339 case EXEC_OMP_SECTIONS
:
9340 case EXEC_OMP_SINGLE
:
9342 case EXEC_OMP_TASKWAIT
:
9343 case EXEC_OMP_TASKYIELD
:
9344 case EXEC_OMP_WORKSHARE
:
9348 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9351 resolve_code (b
->next
, ns
);
9356 /* Does everything to resolve an ordinary assignment. Returns true
9357 if this is an interface assignment. */
9359 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9369 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9373 if (code
->op
== EXEC_ASSIGN_CALL
)
9375 lhs
= code
->ext
.actual
->expr
;
9376 rhsptr
= &code
->ext
.actual
->next
->expr
;
9380 gfc_actual_arglist
* args
;
9381 gfc_typebound_proc
* tbp
;
9383 gcc_assert (code
->op
== EXEC_COMPCALL
);
9385 args
= code
->expr1
->value
.compcall
.actual
;
9387 rhsptr
= &args
->next
->expr
;
9389 tbp
= code
->expr1
->value
.compcall
.tbp
;
9390 gcc_assert (!tbp
->is_generic
);
9393 /* Make a temporary rhs when there is a default initializer
9394 and rhs is the same symbol as the lhs. */
9395 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9396 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9397 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9398 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9399 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9408 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9409 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9410 &code
->loc
) == FAILURE
)
9413 /* Handle the case of a BOZ literal on the RHS. */
9414 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9417 if (gfc_option
.warn_surprising
)
9418 gfc_warning ("BOZ literal at %L is bitwise transferred "
9419 "non-integer symbol '%s'", &code
->loc
,
9420 lhs
->symtree
->n
.sym
->name
);
9422 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9424 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9426 if (rc
== ARITH_UNDERFLOW
)
9427 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9428 ". This check can be disabled with the option "
9429 "-fno-range-check", &rhs
->where
);
9430 else if (rc
== ARITH_OVERFLOW
)
9431 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9432 ". This check can be disabled with the option "
9433 "-fno-range-check", &rhs
->where
);
9434 else if (rc
== ARITH_NAN
)
9435 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9436 ". This check can be disabled with the option "
9437 "-fno-range-check", &rhs
->where
);
9442 if (lhs
->ts
.type
== BT_CHARACTER
9443 && gfc_option
.warn_character_truncation
)
9445 if (lhs
->ts
.u
.cl
!= NULL
9446 && lhs
->ts
.u
.cl
->length
!= NULL
9447 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9448 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9450 if (rhs
->expr_type
== EXPR_CONSTANT
)
9451 rlen
= rhs
->value
.character
.length
;
9453 else if (rhs
->ts
.u
.cl
!= NULL
9454 && rhs
->ts
.u
.cl
->length
!= NULL
9455 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9456 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9458 if (rlen
&& llen
&& rlen
> llen
)
9459 gfc_warning_now ("CHARACTER expression will be truncated "
9460 "in assignment (%d/%d) at %L",
9461 llen
, rlen
, &code
->loc
);
9464 /* Ensure that a vector index expression for the lvalue is evaluated
9465 to a temporary if the lvalue symbol is referenced in it. */
9468 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9469 if (ref
->type
== REF_ARRAY
)
9471 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9472 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9473 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9474 ref
->u
.ar
.start
[n
]))
9476 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9480 if (gfc_pure (NULL
))
9482 if (lhs
->ts
.type
== BT_DERIVED
9483 && lhs
->expr_type
== EXPR_VARIABLE
9484 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9485 && rhs
->expr_type
== EXPR_VARIABLE
9486 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9487 || gfc_is_coindexed (rhs
)))
9490 if (gfc_is_coindexed (rhs
))
9491 gfc_error ("Coindexed expression at %L is assigned to "
9492 "a derived type variable with a POINTER "
9493 "component in a PURE procedure",
9496 gfc_error ("The impure variable at %L is assigned to "
9497 "a derived type variable with a POINTER "
9498 "component in a PURE procedure (12.6)",
9503 /* Fortran 2008, C1283. */
9504 if (gfc_is_coindexed (lhs
))
9506 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9507 "procedure", &rhs
->where
);
9512 if (gfc_implicit_pure (NULL
))
9514 if (lhs
->expr_type
== EXPR_VARIABLE
9515 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9516 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9517 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9519 if (lhs
->ts
.type
== BT_DERIVED
9520 && lhs
->expr_type
== EXPR_VARIABLE
9521 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9522 && rhs
->expr_type
== EXPR_VARIABLE
9523 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9524 || gfc_is_coindexed (rhs
)))
9525 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9527 /* Fortran 2008, C1283. */
9528 if (gfc_is_coindexed (lhs
))
9529 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9533 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9534 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9535 if (lhs
->ts
.type
== BT_CLASS
)
9537 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9538 "%L - check that there is a matching specific subroutine "
9539 "for '=' operator", &lhs
->where
);
9543 /* F2008, Section 7.2.1.2. */
9544 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9546 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9547 "component in assignment at %L", &lhs
->where
);
9551 gfc_check_assign (lhs
, rhs
, 1);
9556 /* Given a block of code, recursively resolve everything pointed to by this
9560 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9562 int omp_workshare_save
;
9563 int forall_save
, do_concurrent_save
;
9567 frame
.prev
= cs_base
;
9571 find_reachable_labels (code
);
9573 for (; code
; code
= code
->next
)
9575 frame
.current
= code
;
9576 forall_save
= forall_flag
;
9577 do_concurrent_save
= do_concurrent_flag
;
9579 if (code
->op
== EXEC_FORALL
)
9582 gfc_resolve_forall (code
, ns
, forall_save
);
9585 else if (code
->block
)
9587 omp_workshare_save
= -1;
9590 case EXEC_OMP_PARALLEL_WORKSHARE
:
9591 omp_workshare_save
= omp_workshare_flag
;
9592 omp_workshare_flag
= 1;
9593 gfc_resolve_omp_parallel_blocks (code
, ns
);
9595 case EXEC_OMP_PARALLEL
:
9596 case EXEC_OMP_PARALLEL_DO
:
9597 case EXEC_OMP_PARALLEL_SECTIONS
:
9599 omp_workshare_save
= omp_workshare_flag
;
9600 omp_workshare_flag
= 0;
9601 gfc_resolve_omp_parallel_blocks (code
, ns
);
9604 gfc_resolve_omp_do_blocks (code
, ns
);
9606 case EXEC_SELECT_TYPE
:
9607 /* Blocks are handled in resolve_select_type because we have
9608 to transform the SELECT TYPE into ASSOCIATE first. */
9610 case EXEC_DO_CONCURRENT
:
9611 do_concurrent_flag
= 1;
9612 gfc_resolve_blocks (code
->block
, ns
);
9613 do_concurrent_flag
= 2;
9615 case EXEC_OMP_WORKSHARE
:
9616 omp_workshare_save
= omp_workshare_flag
;
9617 omp_workshare_flag
= 1;
9620 gfc_resolve_blocks (code
->block
, ns
);
9624 if (omp_workshare_save
!= -1)
9625 omp_workshare_flag
= omp_workshare_save
;
9629 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9630 t
= gfc_resolve_expr (code
->expr1
);
9631 forall_flag
= forall_save
;
9632 do_concurrent_flag
= do_concurrent_save
;
9634 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9637 if (code
->op
== EXEC_ALLOCATE
9638 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9644 case EXEC_END_BLOCK
:
9645 case EXEC_END_NESTED_BLOCK
:
9649 case EXEC_ERROR_STOP
:
9653 case EXEC_ASSIGN_CALL
:
9658 case EXEC_SYNC_IMAGES
:
9659 case EXEC_SYNC_MEMORY
:
9660 resolve_sync (code
);
9665 resolve_lock_unlock (code
);
9669 /* Keep track of which entry we are up to. */
9670 current_entry_id
= code
->ext
.entry
->id
;
9674 resolve_where (code
, NULL
);
9678 if (code
->expr1
!= NULL
)
9680 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9681 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9682 "INTEGER variable", &code
->expr1
->where
);
9683 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9684 gfc_error ("Variable '%s' has not been assigned a target "
9685 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9686 &code
->expr1
->where
);
9689 resolve_branch (code
->label1
, code
);
9693 if (code
->expr1
!= NULL
9694 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9695 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9696 "INTEGER return specifier", &code
->expr1
->where
);
9699 case EXEC_INIT_ASSIGN
:
9700 case EXEC_END_PROCEDURE
:
9707 if (gfc_check_vardef_context (code
->expr1
, false, false, false,
9708 _("assignment")) == FAILURE
)
9711 if (resolve_ordinary_assign (code
, ns
))
9713 if (code
->op
== EXEC_COMPCALL
)
9720 case EXEC_LABEL_ASSIGN
:
9721 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9722 gfc_error ("Label %d referenced at %L is never defined",
9723 code
->label1
->value
, &code
->label1
->where
);
9725 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9726 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9727 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9728 != gfc_default_integer_kind
9729 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9730 gfc_error ("ASSIGN statement at %L requires a scalar "
9731 "default INTEGER variable", &code
->expr1
->where
);
9734 case EXEC_POINTER_ASSIGN
:
9741 /* This is both a variable definition and pointer assignment
9742 context, so check both of them. For rank remapping, a final
9743 array ref may be present on the LHS and fool gfc_expr_attr
9744 used in gfc_check_vardef_context. Remove it. */
9745 e
= remove_last_array_ref (code
->expr1
);
9746 t
= gfc_check_vardef_context (e
, true, false, false,
9747 _("pointer assignment"));
9749 t
= gfc_check_vardef_context (e
, false, false, false,
9750 _("pointer assignment"));
9755 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9759 case EXEC_ARITHMETIC_IF
:
9761 && code
->expr1
->ts
.type
!= BT_INTEGER
9762 && code
->expr1
->ts
.type
!= BT_REAL
)
9763 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9764 "expression", &code
->expr1
->where
);
9766 resolve_branch (code
->label1
, code
);
9767 resolve_branch (code
->label2
, code
);
9768 resolve_branch (code
->label3
, code
);
9772 if (t
== SUCCESS
&& code
->expr1
!= NULL
9773 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9774 || code
->expr1
->rank
!= 0))
9775 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9776 &code
->expr1
->where
);
9781 resolve_call (code
);
9786 resolve_typebound_subroutine (code
);
9790 resolve_ppc_call (code
);
9794 /* Select is complicated. Also, a SELECT construct could be
9795 a transformed computed GOTO. */
9796 resolve_select (code
);
9799 case EXEC_SELECT_TYPE
:
9800 resolve_select_type (code
, ns
);
9804 resolve_block_construct (code
);
9808 if (code
->ext
.iterator
!= NULL
)
9810 gfc_iterator
*iter
= code
->ext
.iterator
;
9811 if (gfc_resolve_iterator (iter
, true, false) != FAILURE
)
9812 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9817 if (code
->expr1
== NULL
)
9818 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9820 && (code
->expr1
->rank
!= 0
9821 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9822 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9823 "a scalar LOGICAL expression", &code
->expr1
->where
);
9828 resolve_allocate_deallocate (code
, "ALLOCATE");
9832 case EXEC_DEALLOCATE
:
9834 resolve_allocate_deallocate (code
, "DEALLOCATE");
9839 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9842 resolve_branch (code
->ext
.open
->err
, code
);
9846 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9849 resolve_branch (code
->ext
.close
->err
, code
);
9852 case EXEC_BACKSPACE
:
9856 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9859 resolve_branch (code
->ext
.filepos
->err
, code
);
9863 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9866 resolve_branch (code
->ext
.inquire
->err
, code
);
9870 gcc_assert (code
->ext
.inquire
!= NULL
);
9871 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9874 resolve_branch (code
->ext
.inquire
->err
, code
);
9878 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9881 resolve_branch (code
->ext
.wait
->err
, code
);
9882 resolve_branch (code
->ext
.wait
->end
, code
);
9883 resolve_branch (code
->ext
.wait
->eor
, code
);
9888 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9891 resolve_branch (code
->ext
.dt
->err
, code
);
9892 resolve_branch (code
->ext
.dt
->end
, code
);
9893 resolve_branch (code
->ext
.dt
->eor
, code
);
9897 resolve_transfer (code
);
9900 case EXEC_DO_CONCURRENT
:
9902 resolve_forall_iterators (code
->ext
.forall_iterator
);
9904 if (code
->expr1
!= NULL
9905 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9906 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9907 "expression", &code
->expr1
->where
);
9910 case EXEC_OMP_ATOMIC
:
9911 case EXEC_OMP_BARRIER
:
9912 case EXEC_OMP_CRITICAL
:
9913 case EXEC_OMP_FLUSH
:
9915 case EXEC_OMP_MASTER
:
9916 case EXEC_OMP_ORDERED
:
9917 case EXEC_OMP_SECTIONS
:
9918 case EXEC_OMP_SINGLE
:
9919 case EXEC_OMP_TASKWAIT
:
9920 case EXEC_OMP_TASKYIELD
:
9921 case EXEC_OMP_WORKSHARE
:
9922 gfc_resolve_omp_directive (code
, ns
);
9925 case EXEC_OMP_PARALLEL
:
9926 case EXEC_OMP_PARALLEL_DO
:
9927 case EXEC_OMP_PARALLEL_SECTIONS
:
9928 case EXEC_OMP_PARALLEL_WORKSHARE
:
9930 omp_workshare_save
= omp_workshare_flag
;
9931 omp_workshare_flag
= 0;
9932 gfc_resolve_omp_directive (code
, ns
);
9933 omp_workshare_flag
= omp_workshare_save
;
9937 gfc_internal_error ("resolve_code(): Bad statement code");
9941 cs_base
= frame
.prev
;
9945 /* Resolve initial values and make sure they are compatible with
9949 resolve_values (gfc_symbol
*sym
)
9953 if (sym
->value
== NULL
)
9956 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9957 t
= resolve_structure_cons (sym
->value
, 1);
9959 t
= gfc_resolve_expr (sym
->value
);
9964 gfc_check_assign_symbol (sym
, sym
->value
);
9968 /* Verify the binding labels for common blocks that are BIND(C). The label
9969 for a BIND(C) common block must be identical in all scoping units in which
9970 the common block is declared. Further, the binding label can not collide
9971 with any other global entity in the program. */
9974 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9976 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9978 gfc_gsymbol
*binding_label_gsym
;
9979 gfc_gsymbol
*comm_name_gsym
;
9980 const char * bind_label
= comm_block_tree
->n
.common
->binding_label
9981 ? comm_block_tree
->n
.common
->binding_label
: "";
9983 /* See if a global symbol exists by the common block's name. It may
9984 be NULL if the common block is use-associated. */
9985 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9986 comm_block_tree
->n
.common
->name
);
9987 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9988 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9989 "with the global entity '%s' at %L",
9991 comm_block_tree
->n
.common
->name
,
9992 &(comm_block_tree
->n
.common
->where
),
9993 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9994 else if (comm_name_gsym
!= NULL
9995 && strcmp (comm_name_gsym
->name
,
9996 comm_block_tree
->n
.common
->name
) == 0)
9998 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
10000 if (comm_name_gsym
->binding_label
== NULL
)
10001 /* No binding label for common block stored yet; save this one. */
10002 comm_name_gsym
->binding_label
= bind_label
;
10003 else if (strcmp (comm_name_gsym
->binding_label
, bind_label
) != 0)
10005 /* Common block names match but binding labels do not. */
10006 gfc_error ("Binding label '%s' for common block '%s' at %L "
10007 "does not match the binding label '%s' for common "
10008 "block '%s' at %L",
10010 comm_block_tree
->n
.common
->name
,
10011 &(comm_block_tree
->n
.common
->where
),
10012 comm_name_gsym
->binding_label
,
10013 comm_name_gsym
->name
,
10014 &(comm_name_gsym
->where
));
10019 /* There is no binding label (NAME="") so we have nothing further to
10020 check and nothing to add as a global symbol for the label. */
10021 if (!comm_block_tree
->n
.common
->binding_label
)
10024 binding_label_gsym
=
10025 gfc_find_gsymbol (gfc_gsym_root
,
10026 comm_block_tree
->n
.common
->binding_label
);
10027 if (binding_label_gsym
== NULL
)
10029 /* Need to make a global symbol for the binding label to prevent
10030 it from colliding with another. */
10031 binding_label_gsym
=
10032 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
10033 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
10034 binding_label_gsym
->type
= GSYM_COMMON
;
10038 /* If comm_name_gsym is NULL, the name common block is use
10039 associated and the name could be colliding. */
10040 if (binding_label_gsym
->type
!= GSYM_COMMON
)
10041 gfc_error ("Binding label '%s' for common block '%s' at %L "
10042 "collides with the global entity '%s' at %L",
10043 comm_block_tree
->n
.common
->binding_label
,
10044 comm_block_tree
->n
.common
->name
,
10045 &(comm_block_tree
->n
.common
->where
),
10046 binding_label_gsym
->name
,
10047 &(binding_label_gsym
->where
));
10048 else if (comm_name_gsym
!= NULL
10049 && (strcmp (binding_label_gsym
->name
,
10050 comm_name_gsym
->binding_label
) != 0)
10051 && (strcmp (binding_label_gsym
->sym_name
,
10052 comm_name_gsym
->name
) != 0))
10053 gfc_error ("Binding label '%s' for common block '%s' at %L "
10054 "collides with global entity '%s' at %L",
10055 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
10056 &(comm_block_tree
->n
.common
->where
),
10057 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
10065 /* Verify any BIND(C) derived types in the namespace so we can report errors
10066 for them once, rather than for each variable declared of that type. */
10069 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10071 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10072 && derived_sym
->attr
.is_bind_c
== 1)
10073 verify_bind_c_derived_type (derived_sym
);
10079 /* Verify that any binding labels used in a given namespace do not collide
10080 with the names or binding labels of any global symbols. */
10083 gfc_verify_binding_labels (gfc_symbol
*sym
)
10087 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
10088 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
)
10090 gfc_gsymbol
*bind_c_sym
;
10092 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10093 if (bind_c_sym
!= NULL
10094 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
10096 if (sym
->attr
.if_source
== IFSRC_DECL
10097 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
10098 && bind_c_sym
->type
!= GSYM_FUNCTION
)
10099 && ((sym
->attr
.contained
== 1
10100 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
10101 || (sym
->attr
.use_assoc
== 1
10102 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
10104 /* Make sure global procedures don't collide with anything. */
10105 gfc_error ("Binding label '%s' at %L collides with the global "
10106 "entity '%s' at %L", sym
->binding_label
,
10107 &(sym
->declared_at
), bind_c_sym
->name
,
10108 &(bind_c_sym
->where
));
10111 else if (sym
->attr
.contained
== 0
10112 && (sym
->attr
.if_source
== IFSRC_IFBODY
10113 && sym
->attr
.flavor
== FL_PROCEDURE
)
10114 && (bind_c_sym
->sym_name
!= NULL
10115 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
10117 /* Make sure procedures in interface bodies don't collide. */
10118 gfc_error ("Binding label '%s' in interface body at %L collides "
10119 "with the global entity '%s' at %L",
10120 sym
->binding_label
,
10121 &(sym
->declared_at
), bind_c_sym
->name
,
10122 &(bind_c_sym
->where
));
10125 else if (sym
->attr
.contained
== 0
10126 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
10127 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
10128 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
10129 || sym
->attr
.use_assoc
== 0)
10131 gfc_error ("Binding label '%s' at %L collides with global "
10132 "entity '%s' at %L", sym
->binding_label
,
10133 &(sym
->declared_at
), bind_c_sym
->name
,
10134 &(bind_c_sym
->where
));
10138 if (has_error
!= 0)
10139 /* Clear the binding label to prevent checking multiple times. */
10140 sym
->binding_label
= NULL
;
10142 else if (bind_c_sym
== NULL
)
10144 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
10145 bind_c_sym
->where
= sym
->declared_at
;
10146 bind_c_sym
->sym_name
= sym
->name
;
10148 if (sym
->attr
.use_assoc
== 1)
10149 bind_c_sym
->mod_name
= sym
->module
;
10151 if (sym
->ns
->proc_name
!= NULL
)
10152 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
10154 if (sym
->attr
.contained
== 0)
10156 if (sym
->attr
.subroutine
)
10157 bind_c_sym
->type
= GSYM_SUBROUTINE
;
10158 else if (sym
->attr
.function
)
10159 bind_c_sym
->type
= GSYM_FUNCTION
;
10167 /* Resolve an index expression. */
10170 resolve_index_expr (gfc_expr
*e
)
10172 if (gfc_resolve_expr (e
) == FAILURE
)
10175 if (gfc_simplify_expr (e
, 0) == FAILURE
)
10178 if (gfc_specification_expr (e
) == FAILURE
)
10185 /* Resolve a charlen structure. */
10188 resolve_charlen (gfc_charlen
*cl
)
10191 bool saved_specification_expr
;
10197 saved_specification_expr
= specification_expr
;
10198 specification_expr
= true;
10200 if (cl
->length_from_typespec
)
10202 if (gfc_resolve_expr (cl
->length
) == FAILURE
)
10204 specification_expr
= saved_specification_expr
;
10208 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
10210 specification_expr
= saved_specification_expr
;
10217 if (resolve_index_expr (cl
->length
) == FAILURE
)
10219 specification_expr
= saved_specification_expr
;
10224 /* "If the character length parameter value evaluates to a negative
10225 value, the length of character entities declared is zero." */
10226 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10228 if (gfc_option
.warn_surprising
)
10229 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10230 " the length has been set to zero",
10231 &cl
->length
->where
, i
);
10232 gfc_replace_expr (cl
->length
,
10233 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10236 /* Check that the character length is not too large. */
10237 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10238 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10239 && cl
->length
->ts
.type
== BT_INTEGER
10240 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10242 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10243 specification_expr
= saved_specification_expr
;
10247 specification_expr
= saved_specification_expr
;
10252 /* Test for non-constant shape arrays. */
10255 is_non_constant_shape_array (gfc_symbol
*sym
)
10261 not_constant
= false;
10262 if (sym
->as
!= NULL
)
10264 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10265 has not been simplified; parameter array references. Do the
10266 simplification now. */
10267 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10269 e
= sym
->as
->lower
[i
];
10270 if (e
&& (resolve_index_expr (e
) == FAILURE
10271 || !gfc_is_constant_expr (e
)))
10272 not_constant
= true;
10273 e
= sym
->as
->upper
[i
];
10274 if (e
&& (resolve_index_expr (e
) == FAILURE
10275 || !gfc_is_constant_expr (e
)))
10276 not_constant
= true;
10279 return not_constant
;
10282 /* Given a symbol and an initialization expression, add code to initialize
10283 the symbol to the function entry. */
10285 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10289 gfc_namespace
*ns
= sym
->ns
;
10291 /* Search for the function namespace if this is a contained
10292 function without an explicit result. */
10293 if (sym
->attr
.function
&& sym
== sym
->result
10294 && sym
->name
!= sym
->ns
->proc_name
->name
)
10296 ns
= ns
->contained
;
10297 for (;ns
; ns
= ns
->sibling
)
10298 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10304 gfc_free_expr (init
);
10308 /* Build an l-value expression for the result. */
10309 lval
= gfc_lval_expr_from_sym (sym
);
10311 /* Add the code at scope entry. */
10312 init_st
= gfc_get_code ();
10313 init_st
->next
= ns
->code
;
10314 ns
->code
= init_st
;
10316 /* Assign the default initializer to the l-value. */
10317 init_st
->loc
= sym
->declared_at
;
10318 init_st
->op
= EXEC_INIT_ASSIGN
;
10319 init_st
->expr1
= lval
;
10320 init_st
->expr2
= init
;
10323 /* Assign the default initializer to a derived type variable or result. */
10326 apply_default_init (gfc_symbol
*sym
)
10328 gfc_expr
*init
= NULL
;
10330 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10333 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10334 init
= gfc_default_initializer (&sym
->ts
);
10336 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10339 build_init_assign (sym
, init
);
10340 sym
->attr
.referenced
= 1;
10343 /* Build an initializer for a local integer, real, complex, logical, or
10344 character variable, based on the command line flags finit-local-zero,
10345 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10346 null if the symbol should not have a default initialization. */
10348 build_default_init_expr (gfc_symbol
*sym
)
10351 gfc_expr
*init_expr
;
10354 /* These symbols should never have a default initialization. */
10355 if (sym
->attr
.allocatable
10356 || sym
->attr
.external
10358 || sym
->attr
.pointer
10359 || sym
->attr
.in_equivalence
10360 || sym
->attr
.in_common
10363 || sym
->attr
.cray_pointee
10364 || sym
->attr
.cray_pointer
10368 /* Now we'll try to build an initializer expression. */
10369 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10370 &sym
->declared_at
);
10372 /* We will only initialize integers, reals, complex, logicals, and
10373 characters, and only if the corresponding command-line flags
10374 were set. Otherwise, we free init_expr and return null. */
10375 switch (sym
->ts
.type
)
10378 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10379 mpz_set_si (init_expr
->value
.integer
,
10380 gfc_option
.flag_init_integer_value
);
10383 gfc_free_expr (init_expr
);
10389 switch (gfc_option
.flag_init_real
)
10391 case GFC_INIT_REAL_SNAN
:
10392 init_expr
->is_snan
= 1;
10393 /* Fall through. */
10394 case GFC_INIT_REAL_NAN
:
10395 mpfr_set_nan (init_expr
->value
.real
);
10398 case GFC_INIT_REAL_INF
:
10399 mpfr_set_inf (init_expr
->value
.real
, 1);
10402 case GFC_INIT_REAL_NEG_INF
:
10403 mpfr_set_inf (init_expr
->value
.real
, -1);
10406 case GFC_INIT_REAL_ZERO
:
10407 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10411 gfc_free_expr (init_expr
);
10418 switch (gfc_option
.flag_init_real
)
10420 case GFC_INIT_REAL_SNAN
:
10421 init_expr
->is_snan
= 1;
10422 /* Fall through. */
10423 case GFC_INIT_REAL_NAN
:
10424 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10425 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10428 case GFC_INIT_REAL_INF
:
10429 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10430 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10433 case GFC_INIT_REAL_NEG_INF
:
10434 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10435 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10438 case GFC_INIT_REAL_ZERO
:
10439 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10443 gfc_free_expr (init_expr
);
10450 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10451 init_expr
->value
.logical
= 0;
10452 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10453 init_expr
->value
.logical
= 1;
10456 gfc_free_expr (init_expr
);
10462 /* For characters, the length must be constant in order to
10463 create a default initializer. */
10464 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10465 && sym
->ts
.u
.cl
->length
10466 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10468 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10469 init_expr
->value
.character
.length
= char_len
;
10470 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10471 for (i
= 0; i
< char_len
; i
++)
10472 init_expr
->value
.character
.string
[i
]
10473 = (unsigned char) gfc_option
.flag_init_character_value
;
10477 gfc_free_expr (init_expr
);
10480 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10481 && sym
->ts
.u
.cl
->length
)
10483 gfc_actual_arglist
*arg
;
10484 init_expr
= gfc_get_expr ();
10485 init_expr
->where
= sym
->declared_at
;
10486 init_expr
->ts
= sym
->ts
;
10487 init_expr
->expr_type
= EXPR_FUNCTION
;
10488 init_expr
->value
.function
.isym
=
10489 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10490 init_expr
->value
.function
.name
= "repeat";
10491 arg
= gfc_get_actual_arglist ();
10492 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10494 arg
->expr
->value
.character
.string
[0]
10495 = gfc_option
.flag_init_character_value
;
10496 arg
->next
= gfc_get_actual_arglist ();
10497 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10498 init_expr
->value
.function
.actual
= arg
;
10503 gfc_free_expr (init_expr
);
10509 /* Add an initialization expression to a local variable. */
10511 apply_default_init_local (gfc_symbol
*sym
)
10513 gfc_expr
*init
= NULL
;
10515 /* The symbol should be a variable or a function return value. */
10516 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10517 || (sym
->attr
.function
&& sym
->result
!= sym
))
10520 /* Try to build the initializer expression. If we can't initialize
10521 this symbol, then init will be NULL. */
10522 init
= build_default_init_expr (sym
);
10526 /* For saved variables, we don't want to add an initializer at function
10527 entry, so we just add a static initializer. Note that automatic variables
10528 are stack allocated even with -fno-automatic. */
10529 if (sym
->attr
.save
|| sym
->ns
->save_all
10530 || (gfc_option
.flag_max_stack_var_size
== 0
10531 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10533 /* Don't clobber an existing initializer! */
10534 gcc_assert (sym
->value
== NULL
);
10539 build_init_assign (sym
, init
);
10543 /* Resolution of common features of flavors variable and procedure. */
10546 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10548 gfc_array_spec
*as
;
10550 /* Avoid double diagnostics for function result symbols. */
10551 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10552 && (sym
->ns
!= gfc_current_ns
))
10555 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10556 as
= CLASS_DATA (sym
)->as
;
10560 /* Constraints on deferred shape variable. */
10561 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10563 bool pointer
, allocatable
, dimension
;
10565 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10567 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10568 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10569 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10573 pointer
= sym
->attr
.pointer
;
10574 allocatable
= sym
->attr
.allocatable
;
10575 dimension
= sym
->attr
.dimension
;
10580 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10582 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10583 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10586 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10587 "'%s' at %L may not be ALLOCATABLE",
10588 sym
->name
, &sym
->declared_at
) == FAILURE
)
10592 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10594 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10595 "assumed rank", sym
->name
, &sym
->declared_at
);
10601 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10602 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10604 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10605 sym
->name
, &sym
->declared_at
);
10610 /* Constraints on polymorphic variables. */
10611 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10614 if (sym
->attr
.class_ok
10615 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10617 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10618 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10619 &sym
->declared_at
);
10624 /* Assume that use associated symbols were checked in the module ns.
10625 Class-variables that are associate-names are also something special
10626 and excepted from the test. */
10627 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10629 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10630 "or pointer", sym
->name
, &sym
->declared_at
);
10639 /* Additional checks for symbols with flavor variable and derived
10640 type. To be called from resolve_fl_variable. */
10643 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10645 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10647 /* Check to see if a derived type is blocked from being host
10648 associated by the presence of another class I symbol in the same
10649 namespace. 14.6.1.3 of the standard and the discussion on
10650 comp.lang.fortran. */
10651 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10652 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10655 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10656 if (s
&& s
->attr
.generic
)
10657 s
= gfc_find_dt_in_generic (s
);
10658 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10660 gfc_error ("The type '%s' cannot be host associated at %L "
10661 "because it is blocked by an incompatible object "
10662 "of the same name declared at %L",
10663 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10669 /* 4th constraint in section 11.3: "If an object of a type for which
10670 component-initialization is specified (R429) appears in the
10671 specification-part of a module and does not have the ALLOCATABLE
10672 or POINTER attribute, the object shall have the SAVE attribute."
10674 The check for initializers is performed with
10675 gfc_has_default_initializer because gfc_default_initializer generates
10676 a hidden default for allocatable components. */
10677 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10678 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10679 && !sym
->ns
->save_all
&& !sym
->attr
.save
10680 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10681 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10682 && gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for "
10683 "module variable '%s' at %L, needed due to "
10684 "the default initialization", sym
->name
,
10685 &sym
->declared_at
) == FAILURE
)
10688 /* Assign default initializer. */
10689 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10690 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10692 sym
->value
= gfc_default_initializer (&sym
->ts
);
10699 /* Resolve symbols with flavor variable. */
10702 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10704 int no_init_flag
, automatic_flag
;
10706 const char *auto_save_msg
;
10707 bool saved_specification_expr
;
10709 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10712 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10715 /* Set this flag to check that variables are parameters of all entries.
10716 This check is effected by the call to gfc_resolve_expr through
10717 is_non_constant_shape_array. */
10718 saved_specification_expr
= specification_expr
;
10719 specification_expr
= true;
10721 if (sym
->ns
->proc_name
10722 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10723 || sym
->ns
->proc_name
->attr
.is_main_program
)
10724 && !sym
->attr
.use_assoc
10725 && !sym
->attr
.allocatable
10726 && !sym
->attr
.pointer
10727 && is_non_constant_shape_array (sym
))
10729 /* The shape of a main program or module array needs to be
10731 gfc_error ("The module or main program array '%s' at %L must "
10732 "have constant shape", sym
->name
, &sym
->declared_at
);
10733 specification_expr
= saved_specification_expr
;
10737 /* Constraints on deferred type parameter. */
10738 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10740 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10741 "requires either the pointer or allocatable attribute",
10742 sym
->name
, &sym
->declared_at
);
10743 specification_expr
= saved_specification_expr
;
10747 if (sym
->ts
.type
== BT_CHARACTER
)
10749 /* Make sure that character string variables with assumed length are
10750 dummy arguments. */
10751 e
= sym
->ts
.u
.cl
->length
;
10752 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10753 && !sym
->ts
.deferred
)
10755 gfc_error ("Entity with assumed character length at %L must be a "
10756 "dummy argument or a PARAMETER", &sym
->declared_at
);
10757 specification_expr
= saved_specification_expr
;
10761 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10763 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10764 specification_expr
= saved_specification_expr
;
10768 if (!gfc_is_constant_expr (e
)
10769 && !(e
->expr_type
== EXPR_VARIABLE
10770 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10772 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10773 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10774 || sym
->ns
->proc_name
->attr
.is_main_program
))
10776 gfc_error ("'%s' at %L must have constant character length "
10777 "in this context", sym
->name
, &sym
->declared_at
);
10778 specification_expr
= saved_specification_expr
;
10781 if (sym
->attr
.in_common
)
10783 gfc_error ("COMMON variable '%s' at %L must have constant "
10784 "character length", sym
->name
, &sym
->declared_at
);
10785 specification_expr
= saved_specification_expr
;
10791 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10792 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10794 /* Determine if the symbol may not have an initializer. */
10795 no_init_flag
= automatic_flag
= 0;
10796 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10797 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10799 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10800 && is_non_constant_shape_array (sym
))
10802 no_init_flag
= automatic_flag
= 1;
10804 /* Also, they must not have the SAVE attribute.
10805 SAVE_IMPLICIT is checked below. */
10806 if (sym
->as
&& sym
->attr
.codimension
)
10808 int corank
= sym
->as
->corank
;
10809 sym
->as
->corank
= 0;
10810 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10811 sym
->as
->corank
= corank
;
10813 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10815 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10816 specification_expr
= saved_specification_expr
;
10821 /* Ensure that any initializer is simplified. */
10823 gfc_simplify_expr (sym
->value
, 1);
10825 /* Reject illegal initializers. */
10826 if (!sym
->mark
&& sym
->value
)
10828 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10829 && CLASS_DATA (sym
)->attr
.allocatable
))
10830 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10831 sym
->name
, &sym
->declared_at
);
10832 else if (sym
->attr
.external
)
10833 gfc_error ("External '%s' at %L cannot have an initializer",
10834 sym
->name
, &sym
->declared_at
);
10835 else if (sym
->attr
.dummy
10836 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10837 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10838 sym
->name
, &sym
->declared_at
);
10839 else if (sym
->attr
.intrinsic
)
10840 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10841 sym
->name
, &sym
->declared_at
);
10842 else if (sym
->attr
.result
)
10843 gfc_error ("Function result '%s' at %L cannot have an initializer",
10844 sym
->name
, &sym
->declared_at
);
10845 else if (automatic_flag
)
10846 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10847 sym
->name
, &sym
->declared_at
);
10849 goto no_init_error
;
10850 specification_expr
= saved_specification_expr
;
10855 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10857 gfc_try res
= resolve_fl_variable_derived (sym
, no_init_flag
);
10858 specification_expr
= saved_specification_expr
;
10862 specification_expr
= saved_specification_expr
;
10867 /* Resolve a procedure. */
10870 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10872 gfc_formal_arglist
*arg
;
10874 if (sym
->attr
.function
10875 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10878 if (sym
->ts
.type
== BT_CHARACTER
)
10880 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10882 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10883 && resolve_charlen (cl
) == FAILURE
)
10886 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10887 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10889 gfc_error ("Character-valued statement function '%s' at %L must "
10890 "have constant length", sym
->name
, &sym
->declared_at
);
10895 /* Ensure that derived type for are not of a private type. Internal
10896 module procedures are excluded by 2.2.3.3 - i.e., they are not
10897 externally accessible and can access all the objects accessible in
10899 if (!(sym
->ns
->parent
10900 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10901 && gfc_check_symbol_access (sym
))
10903 gfc_interface
*iface
;
10905 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10908 && arg
->sym
->ts
.type
== BT_DERIVED
10909 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10910 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10911 && gfc_notify_std (GFC_STD_F2003
, "'%s' is of a "
10912 "PRIVATE type and cannot be a dummy argument"
10913 " of '%s', which is PUBLIC at %L",
10914 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10917 /* Stop this message from recurring. */
10918 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10923 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10924 PRIVATE to the containing module. */
10925 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10927 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10930 && arg
->sym
->ts
.type
== BT_DERIVED
10931 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10932 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10933 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
10934 "'%s' in PUBLIC interface '%s' at %L "
10935 "takes dummy arguments of '%s' which is "
10936 "PRIVATE", iface
->sym
->name
, sym
->name
,
10937 &iface
->sym
->declared_at
,
10938 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10940 /* Stop this message from recurring. */
10941 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10947 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10948 PRIVATE to the containing module. */
10949 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10951 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10954 && arg
->sym
->ts
.type
== BT_DERIVED
10955 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10956 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10957 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
10958 "'%s' in PUBLIC interface '%s' at %L "
10959 "takes dummy arguments of '%s' which is "
10960 "PRIVATE", iface
->sym
->name
, sym
->name
,
10961 &iface
->sym
->declared_at
,
10962 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10964 /* Stop this message from recurring. */
10965 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10972 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10973 && !sym
->attr
.proc_pointer
)
10975 gfc_error ("Function '%s' at %L cannot have an initializer",
10976 sym
->name
, &sym
->declared_at
);
10980 /* An external symbol may not have an initializer because it is taken to be
10981 a procedure. Exception: Procedure Pointers. */
10982 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10984 gfc_error ("External object '%s' at %L may not have an initializer",
10985 sym
->name
, &sym
->declared_at
);
10989 /* An elemental function is required to return a scalar 12.7.1 */
10990 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10992 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10993 "result", sym
->name
, &sym
->declared_at
);
10994 /* Reset so that the error only occurs once. */
10995 sym
->attr
.elemental
= 0;
10999 if (sym
->attr
.proc
== PROC_ST_FUNCTION
11000 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
11002 gfc_error ("Statement function '%s' at %L may not have pointer or "
11003 "allocatable attribute", sym
->name
, &sym
->declared_at
);
11007 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
11008 char-len-param shall not be array-valued, pointer-valued, recursive
11009 or pure. ....snip... A character value of * may only be used in the
11010 following ways: (i) Dummy arg of procedure - dummy associates with
11011 actual length; (ii) To declare a named constant; or (iii) External
11012 function - but length must be declared in calling scoping unit. */
11013 if (sym
->attr
.function
11014 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
11015 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
11017 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
11018 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
11020 if (sym
->as
&& sym
->as
->rank
)
11021 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11022 "array-valued", sym
->name
, &sym
->declared_at
);
11024 if (sym
->attr
.pointer
)
11025 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11026 "pointer-valued", sym
->name
, &sym
->declared_at
);
11028 if (sym
->attr
.pure
)
11029 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11030 "pure", sym
->name
, &sym
->declared_at
);
11032 if (sym
->attr
.recursive
)
11033 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
11034 "recursive", sym
->name
, &sym
->declared_at
);
11039 /* Appendix B.2 of the standard. Contained functions give an
11040 error anyway. Fixed-form is likely to be F77/legacy. Deferred
11041 character length is an F2003 feature. */
11042 if (!sym
->attr
.contained
11043 && gfc_current_form
!= FORM_FIXED
11044 && !sym
->ts
.deferred
)
11045 gfc_notify_std (GFC_STD_F95_OBS
,
11046 "CHARACTER(*) function '%s' at %L",
11047 sym
->name
, &sym
->declared_at
);
11050 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
11052 gfc_formal_arglist
*curr_arg
;
11053 int has_non_interop_arg
= 0;
11055 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
11056 sym
->common_block
) == FAILURE
)
11058 /* Clear these to prevent looking at them again if there was an
11060 sym
->attr
.is_bind_c
= 0;
11061 sym
->attr
.is_c_interop
= 0;
11062 sym
->ts
.is_c_interop
= 0;
11066 /* So far, no errors have been found. */
11067 sym
->attr
.is_c_interop
= 1;
11068 sym
->ts
.is_c_interop
= 1;
11071 curr_arg
= sym
->formal
;
11072 while (curr_arg
!= NULL
)
11074 /* Skip implicitly typed dummy args here. */
11075 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11076 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
11077 /* If something is found to fail, record the fact so we
11078 can mark the symbol for the procedure as not being
11079 BIND(C) to try and prevent multiple errors being
11081 has_non_interop_arg
= 1;
11083 curr_arg
= curr_arg
->next
;
11086 /* See if any of the arguments were not interoperable and if so, clear
11087 the procedure symbol to prevent duplicate error messages. */
11088 if (has_non_interop_arg
!= 0)
11090 sym
->attr
.is_c_interop
= 0;
11091 sym
->ts
.is_c_interop
= 0;
11092 sym
->attr
.is_bind_c
= 0;
11096 if (!sym
->attr
.proc_pointer
)
11098 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11100 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11101 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11104 if (sym
->attr
.intent
)
11106 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11107 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11110 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11112 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11113 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11116 if (sym
->attr
.external
&& sym
->attr
.function
11117 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11118 || sym
->attr
.contained
))
11120 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11121 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11124 if (strcmp ("ppr@", sym
->name
) == 0)
11126 gfc_error ("Procedure pointer result '%s' at %L "
11127 "is missing the pointer attribute",
11128 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11137 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11138 been defined and we now know their defined arguments, check that they fulfill
11139 the requirements of the standard for procedures used as finalizers. */
11142 gfc_resolve_finalizers (gfc_symbol
* derived
)
11144 gfc_finalizer
* list
;
11145 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11146 gfc_try result
= SUCCESS
;
11147 bool seen_scalar
= false;
11149 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11152 /* Walk over the list of finalizer-procedures, check them, and if any one
11153 does not fit in with the standard's definition, print an error and remove
11154 it from the list. */
11155 prev_link
= &derived
->f2k_derived
->finalizers
;
11156 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11162 /* Skip this finalizer if we already resolved it. */
11163 if (list
->proc_tree
)
11165 prev_link
= &(list
->next
);
11169 /* Check this exists and is a SUBROUTINE. */
11170 if (!list
->proc_sym
->attr
.subroutine
)
11172 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11173 list
->proc_sym
->name
, &list
->where
);
11177 /* We should have exactly one argument. */
11178 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
11180 gfc_error ("FINAL procedure at %L must have exactly one argument",
11184 arg
= list
->proc_sym
->formal
->sym
;
11186 /* This argument must be of our type. */
11187 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11189 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11190 &arg
->declared_at
, derived
->name
);
11194 /* It must neither be a pointer nor allocatable nor optional. */
11195 if (arg
->attr
.pointer
)
11197 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11198 &arg
->declared_at
);
11201 if (arg
->attr
.allocatable
)
11203 gfc_error ("Argument of FINAL procedure at %L must not be"
11204 " ALLOCATABLE", &arg
->declared_at
);
11207 if (arg
->attr
.optional
)
11209 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11210 &arg
->declared_at
);
11214 /* It must not be INTENT(OUT). */
11215 if (arg
->attr
.intent
== INTENT_OUT
)
11217 gfc_error ("Argument of FINAL procedure at %L must not be"
11218 " INTENT(OUT)", &arg
->declared_at
);
11222 /* Warn if the procedure is non-scalar and not assumed shape. */
11223 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11224 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11225 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11226 " shape argument", &arg
->declared_at
);
11228 /* Check that it does not match in kind and rank with a FINAL procedure
11229 defined earlier. To really loop over the *earlier* declarations,
11230 we need to walk the tail of the list as new ones were pushed at the
11232 /* TODO: Handle kind parameters once they are implemented. */
11233 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11234 for (i
= list
->next
; i
; i
= i
->next
)
11236 /* Argument list might be empty; that is an error signalled earlier,
11237 but we nevertheless continued resolving. */
11238 if (i
->proc_sym
->formal
)
11240 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
11241 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11242 if (i_rank
== my_rank
)
11244 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11245 " rank (%d) as '%s'",
11246 list
->proc_sym
->name
, &list
->where
, my_rank
,
11247 i
->proc_sym
->name
);
11253 /* Is this the/a scalar finalizer procedure? */
11254 if (!arg
->as
|| arg
->as
->rank
== 0)
11255 seen_scalar
= true;
11257 /* Find the symtree for this procedure. */
11258 gcc_assert (!list
->proc_tree
);
11259 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11261 prev_link
= &list
->next
;
11264 /* Remove wrong nodes immediately from the list so we don't risk any
11265 troubles in the future when they might fail later expectations. */
11269 *prev_link
= list
->next
;
11270 gfc_free_finalizer (i
);
11273 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11274 were nodes in the list, must have been for arrays. It is surely a good
11275 idea to have a scalar version there if there's something to finalize. */
11276 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
11277 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11278 " defined at %L, suggest also scalar one",
11279 derived
->name
, &derived
->declared_at
);
11281 /* TODO: Remove this error when finalization is finished. */
11282 gfc_error ("Finalization at %L is not yet implemented",
11283 &derived
->declared_at
);
11285 gfc_find_derived_vtab (derived
);
11290 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11293 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11294 const char* generic_name
, locus where
)
11296 gfc_symbol
*sym1
, *sym2
;
11297 const char *pass1
, *pass2
;
11299 gcc_assert (t1
->specific
&& t2
->specific
);
11300 gcc_assert (!t1
->specific
->is_generic
);
11301 gcc_assert (!t2
->specific
->is_generic
);
11302 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11304 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11305 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11310 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11311 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11312 || sym1
->attr
.function
!= sym2
->attr
.function
)
11314 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11315 " GENERIC '%s' at %L",
11316 sym1
->name
, sym2
->name
, generic_name
, &where
);
11320 /* Compare the interfaces. */
11321 if (t1
->specific
->nopass
)
11323 else if (t1
->specific
->pass_arg
)
11324 pass1
= t1
->specific
->pass_arg
;
11326 pass1
= t1
->specific
->u
.specific
->n
.sym
->formal
->sym
->name
;
11327 if (t2
->specific
->nopass
)
11329 else if (t2
->specific
->pass_arg
)
11330 pass2
= t2
->specific
->pass_arg
;
11332 pass2
= t2
->specific
->u
.specific
->n
.sym
->formal
->sym
->name
;
11333 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11334 NULL
, 0, pass1
, pass2
))
11336 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11337 sym1
->name
, sym2
->name
, generic_name
, &where
);
11345 /* Worker function for resolving a generic procedure binding; this is used to
11346 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11348 The difference between those cases is finding possible inherited bindings
11349 that are overridden, as one has to look for them in tb_sym_root,
11350 tb_uop_root or tb_op, respectively. Thus the caller must already find
11351 the super-type and set p->overridden correctly. */
11354 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11355 gfc_typebound_proc
* p
, const char* name
)
11357 gfc_tbp_generic
* target
;
11358 gfc_symtree
* first_target
;
11359 gfc_symtree
* inherited
;
11361 gcc_assert (p
&& p
->is_generic
);
11363 /* Try to find the specific bindings for the symtrees in our target-list. */
11364 gcc_assert (p
->u
.generic
);
11365 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11366 if (!target
->specific
)
11368 gfc_typebound_proc
* overridden_tbp
;
11369 gfc_tbp_generic
* g
;
11370 const char* target_name
;
11372 target_name
= target
->specific_st
->name
;
11374 /* Defined for this type directly. */
11375 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11377 target
->specific
= target
->specific_st
->n
.tb
;
11378 goto specific_found
;
11381 /* Look for an inherited specific binding. */
11384 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11389 gcc_assert (inherited
->n
.tb
);
11390 target
->specific
= inherited
->n
.tb
;
11391 goto specific_found
;
11395 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11396 " at %L", target_name
, name
, &p
->where
);
11399 /* Once we've found the specific binding, check it is not ambiguous with
11400 other specifics already found or inherited for the same GENERIC. */
11402 gcc_assert (target
->specific
);
11404 /* This must really be a specific binding! */
11405 if (target
->specific
->is_generic
)
11407 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11408 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11412 /* Check those already resolved on this type directly. */
11413 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11414 if (g
!= target
&& g
->specific
11415 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11419 /* Check for ambiguity with inherited specific targets. */
11420 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11421 overridden_tbp
= overridden_tbp
->overridden
)
11422 if (overridden_tbp
->is_generic
)
11424 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11426 gcc_assert (g
->specific
);
11427 if (check_generic_tbp_ambiguity (target
, g
,
11428 name
, p
->where
) == FAILURE
)
11434 /* If we attempt to "overwrite" a specific binding, this is an error. */
11435 if (p
->overridden
&& !p
->overridden
->is_generic
)
11437 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11438 " the same name", name
, &p
->where
);
11442 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11443 all must have the same attributes here. */
11444 first_target
= p
->u
.generic
->specific
->u
.specific
;
11445 gcc_assert (first_target
);
11446 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11447 p
->function
= first_target
->n
.sym
->attr
.function
;
11453 /* Resolve a GENERIC procedure binding for a derived type. */
11456 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11458 gfc_symbol
* super_type
;
11460 /* Find the overridden binding if any. */
11461 st
->n
.tb
->overridden
= NULL
;
11462 super_type
= gfc_get_derived_super_type (derived
);
11465 gfc_symtree
* overridden
;
11466 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11469 if (overridden
&& overridden
->n
.tb
)
11470 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11473 /* Resolve using worker function. */
11474 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11478 /* Retrieve the target-procedure of an operator binding and do some checks in
11479 common for intrinsic and user-defined type-bound operators. */
11482 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11484 gfc_symbol
* target_proc
;
11486 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11487 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11488 gcc_assert (target_proc
);
11490 /* F08:C468. All operator bindings must have a passed-object dummy argument. */
11491 if (target
->specific
->nopass
)
11493 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11497 return target_proc
;
11501 /* Resolve a type-bound intrinsic operator. */
11504 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11505 gfc_typebound_proc
* p
)
11507 gfc_symbol
* super_type
;
11508 gfc_tbp_generic
* target
;
11510 /* If there's already an error here, do nothing (but don't fail again). */
11514 /* Operators should always be GENERIC bindings. */
11515 gcc_assert (p
->is_generic
);
11517 /* Look for an overridden binding. */
11518 super_type
= gfc_get_derived_super_type (derived
);
11519 if (super_type
&& super_type
->f2k_derived
)
11520 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11523 p
->overridden
= NULL
;
11525 /* Resolve general GENERIC properties using worker function. */
11526 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11529 /* Check the targets to be procedures of correct interface. */
11530 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11532 gfc_symbol
* target_proc
;
11534 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11538 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11541 /* Add target to non-typebound operator list. */
11542 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11543 && p
->access
!= ACCESS_PRIVATE
&& derived
->ns
== gfc_current_ns
)
11545 gfc_interface
*head
, *intr
;
11546 if (gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
,
11547 p
->where
) == FAILURE
)
11549 head
= derived
->ns
->op
[op
];
11550 intr
= gfc_get_interface ();
11551 intr
->sym
= target_proc
;
11552 intr
->where
= p
->where
;
11554 derived
->ns
->op
[op
] = intr
;
11566 /* Resolve a type-bound user operator (tree-walker callback). */
11568 static gfc_symbol
* resolve_bindings_derived
;
11569 static gfc_try resolve_bindings_result
;
11571 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11574 resolve_typebound_user_op (gfc_symtree
* stree
)
11576 gfc_symbol
* super_type
;
11577 gfc_tbp_generic
* target
;
11579 gcc_assert (stree
&& stree
->n
.tb
);
11581 if (stree
->n
.tb
->error
)
11584 /* Operators should always be GENERIC bindings. */
11585 gcc_assert (stree
->n
.tb
->is_generic
);
11587 /* Find overridden procedure, if any. */
11588 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11589 if (super_type
&& super_type
->f2k_derived
)
11591 gfc_symtree
* overridden
;
11592 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11593 stree
->name
, true, NULL
);
11595 if (overridden
&& overridden
->n
.tb
)
11596 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11599 stree
->n
.tb
->overridden
= NULL
;
11601 /* Resolve basically using worker function. */
11602 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11606 /* Check the targets to be functions of correct interface. */
11607 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11609 gfc_symbol
* target_proc
;
11611 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11615 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11622 resolve_bindings_result
= FAILURE
;
11623 stree
->n
.tb
->error
= 1;
11627 /* Resolve the type-bound procedures for a derived type. */
11630 resolve_typebound_procedure (gfc_symtree
* stree
)
11634 gfc_symbol
* me_arg
;
11635 gfc_symbol
* super_type
;
11636 gfc_component
* comp
;
11638 gcc_assert (stree
);
11640 /* Undefined specific symbol from GENERIC target definition. */
11644 if (stree
->n
.tb
->error
)
11647 /* If this is a GENERIC binding, use that routine. */
11648 if (stree
->n
.tb
->is_generic
)
11650 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11656 /* Get the target-procedure to check it. */
11657 gcc_assert (!stree
->n
.tb
->is_generic
);
11658 gcc_assert (stree
->n
.tb
->u
.specific
);
11659 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11660 where
= stree
->n
.tb
->where
;
11661 proc
->attr
.public_used
= 1;
11663 /* Default access should already be resolved from the parser. */
11664 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11666 if (stree
->n
.tb
->deferred
)
11668 if (check_proc_interface (proc
, &where
) == FAILURE
)
11673 /* Check for F08:C465. */
11674 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11675 || (proc
->attr
.proc
!= PROC_MODULE
11676 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11677 || proc
->attr
.abstract
)
11679 gfc_error ("'%s' must be a module procedure or an external procedure with"
11680 " an explicit interface at %L", proc
->name
, &where
);
11685 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11686 stree
->n
.tb
->function
= proc
->attr
.function
;
11688 /* Find the super-type of the current derived type. We could do this once and
11689 store in a global if speed is needed, but as long as not I believe this is
11690 more readable and clearer. */
11691 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11693 /* If PASS, resolve and check arguments if not already resolved / loaded
11694 from a .mod file. */
11695 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11697 if (stree
->n
.tb
->pass_arg
)
11699 gfc_formal_arglist
* i
;
11701 /* If an explicit passing argument name is given, walk the arg-list
11702 and look for it. */
11705 stree
->n
.tb
->pass_arg_num
= 1;
11706 for (i
= proc
->formal
; i
; i
= i
->next
)
11708 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11713 ++stree
->n
.tb
->pass_arg_num
;
11718 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11720 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11721 stree
->n
.tb
->pass_arg
);
11727 /* Otherwise, take the first one; there should in fact be at least
11729 stree
->n
.tb
->pass_arg_num
= 1;
11732 gfc_error ("Procedure '%s' with PASS at %L must have at"
11733 " least one argument", proc
->name
, &where
);
11736 me_arg
= proc
->formal
->sym
;
11739 /* Now check that the argument-type matches and the passed-object
11740 dummy argument is generally fine. */
11742 gcc_assert (me_arg
);
11744 if (me_arg
->ts
.type
!= BT_CLASS
)
11746 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11747 " at %L", proc
->name
, &where
);
11751 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11752 != resolve_bindings_derived
)
11754 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11755 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11756 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11760 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11761 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11763 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11764 " scalar", proc
->name
, &where
);
11767 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11769 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11770 " be ALLOCATABLE", proc
->name
, &where
);
11773 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11775 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11776 " be POINTER", proc
->name
, &where
);
11781 /* If we are extending some type, check that we don't override a procedure
11782 flagged NON_OVERRIDABLE. */
11783 stree
->n
.tb
->overridden
= NULL
;
11786 gfc_symtree
* overridden
;
11787 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11788 stree
->name
, true, NULL
);
11792 if (overridden
->n
.tb
)
11793 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11795 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11800 /* See if there's a name collision with a component directly in this type. */
11801 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11802 if (!strcmp (comp
->name
, stree
->name
))
11804 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11806 stree
->name
, &where
, resolve_bindings_derived
->name
);
11810 /* Try to find a name collision with an inherited component. */
11811 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11813 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11814 " component of '%s'",
11815 stree
->name
, &where
, resolve_bindings_derived
->name
);
11819 stree
->n
.tb
->error
= 0;
11823 resolve_bindings_result
= FAILURE
;
11824 stree
->n
.tb
->error
= 1;
11829 resolve_typebound_procedures (gfc_symbol
* derived
)
11832 gfc_symbol
* super_type
;
11834 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11837 super_type
= gfc_get_derived_super_type (derived
);
11839 resolve_typebound_procedures (super_type
);
11841 resolve_bindings_derived
= derived
;
11842 resolve_bindings_result
= SUCCESS
;
11844 /* Make sure the vtab has been generated. */
11845 gfc_find_derived_vtab (derived
);
11847 if (derived
->f2k_derived
->tb_sym_root
)
11848 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11849 &resolve_typebound_procedure
);
11851 if (derived
->f2k_derived
->tb_uop_root
)
11852 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11853 &resolve_typebound_user_op
);
11855 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11857 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11858 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11860 resolve_bindings_result
= FAILURE
;
11863 return resolve_bindings_result
;
11867 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11868 to give all identical derived types the same backend_decl. */
11870 add_dt_to_dt_list (gfc_symbol
*derived
)
11872 gfc_dt_list
*dt_list
;
11874 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11875 if (derived
== dt_list
->derived
)
11878 dt_list
= gfc_get_dt_list ();
11879 dt_list
->next
= gfc_derived_types
;
11880 dt_list
->derived
= derived
;
11881 gfc_derived_types
= dt_list
;
11885 /* Ensure that a derived-type is really not abstract, meaning that every
11886 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11889 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11894 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11896 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11899 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11901 gfc_symtree
* overriding
;
11902 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11905 gcc_assert (overriding
->n
.tb
);
11906 if (overriding
->n
.tb
->deferred
)
11908 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11909 " '%s' is DEFERRED and not overridden",
11910 sub
->name
, &sub
->declared_at
, st
->name
);
11919 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11921 /* The algorithm used here is to recursively travel up the ancestry of sub
11922 and for each ancestor-type, check all bindings. If any of them is
11923 DEFERRED, look it up starting from sub and see if the found (overriding)
11924 binding is not DEFERRED.
11925 This is not the most efficient way to do this, but it should be ok and is
11926 clearer than something sophisticated. */
11928 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11930 if (!ancestor
->attr
.abstract
)
11933 /* Walk bindings of this ancestor. */
11934 if (ancestor
->f2k_derived
)
11937 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11942 /* Find next ancestor type and recurse on it. */
11943 ancestor
= gfc_get_derived_super_type (ancestor
);
11945 return ensure_not_abstract (sub
, ancestor
);
11951 /* Resolve the components of a derived type. This does not have to wait until
11952 resolution stage, but can be done as soon as the dt declaration has been
11956 resolve_fl_derived0 (gfc_symbol
*sym
)
11958 gfc_symbol
* super_type
;
11961 super_type
= gfc_get_derived_super_type (sym
);
11964 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11966 gfc_error ("As extending type '%s' at %L has a coarray component, "
11967 "parent type '%s' shall also have one", sym
->name
,
11968 &sym
->declared_at
, super_type
->name
);
11972 /* Ensure the extended type gets resolved before we do. */
11973 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11976 /* An ABSTRACT type must be extensible. */
11977 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11979 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11980 sym
->name
, &sym
->declared_at
);
11984 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11987 for ( ; c
!= NULL
; c
= c
->next
)
11989 if (c
->attr
.artificial
)
11992 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11993 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
11995 gfc_error ("Deferred-length character component '%s' at %L is not "
11996 "yet supported", c
->name
, &c
->loc
);
12001 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
12002 && c
->attr
.codimension
12003 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
12005 gfc_error ("Coarray component '%s' at %L must be allocatable with "
12006 "deferred shape", c
->name
, &c
->loc
);
12011 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
12012 && c
->ts
.u
.derived
->ts
.is_iso_c
)
12014 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12015 "shall not be a coarray", c
->name
, &c
->loc
);
12020 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
12021 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
12022 || c
->attr
.allocatable
))
12024 gfc_error ("Component '%s' at %L with coarray component "
12025 "shall be a nonpointer, nonallocatable scalar",
12031 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
12033 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
12034 "is not an array pointer", c
->name
, &c
->loc
);
12038 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
12040 gfc_symbol
*ifc
= c
->ts
.interface
;
12042 if (!sym
->attr
.vtype
12043 && check_proc_interface (ifc
, &c
->loc
) == FAILURE
)
12046 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
12048 /* Resolve interface and copy attributes. */
12049 if (ifc
->formal
&& !ifc
->formal_ns
)
12050 resolve_symbol (ifc
);
12051 if (ifc
->attr
.intrinsic
)
12052 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
12056 c
->ts
= ifc
->result
->ts
;
12057 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
12058 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
12059 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12060 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12061 c
->attr
.class_ok
= ifc
->result
->attr
.class_ok
;
12066 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12067 c
->attr
.pointer
= ifc
->attr
.pointer
;
12068 c
->attr
.dimension
= ifc
->attr
.dimension
;
12069 c
->as
= gfc_copy_array_spec (ifc
->as
);
12070 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12072 c
->ts
.interface
= ifc
;
12073 c
->attr
.function
= ifc
->attr
.function
;
12074 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12075 gfc_copy_formal_args_ppc (c
, ifc
, IFSRC_DECL
);
12077 c
->attr
.pure
= ifc
->attr
.pure
;
12078 c
->attr
.elemental
= ifc
->attr
.elemental
;
12079 c
->attr
.recursive
= ifc
->attr
.recursive
;
12080 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12081 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12082 /* Replace symbols in array spec. */
12086 for (i
= 0; i
< c
->as
->rank
; i
++)
12088 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
12089 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
12092 /* Copy char length. */
12093 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12095 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12096 gfc_expr_replace_comp (cl
->length
, c
);
12097 if (cl
->length
&& !cl
->resolved
12098 && gfc_resolve_expr (cl
->length
) == FAILURE
)
12104 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12106 /* Since PPCs are not implicitly typed, a PPC without an explicit
12107 interface must be a subroutine. */
12108 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12111 /* Procedure pointer components: Check PASS arg. */
12112 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12113 && !sym
->attr
.vtype
)
12115 gfc_symbol
* me_arg
;
12117 if (c
->tb
->pass_arg
)
12119 gfc_formal_arglist
* i
;
12121 /* If an explicit passing argument name is given, walk the arg-list
12122 and look for it. */
12125 c
->tb
->pass_arg_num
= 1;
12126 for (i
= c
->formal
; i
; i
= i
->next
)
12128 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12133 c
->tb
->pass_arg_num
++;
12138 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12139 "at %L has no argument '%s'", c
->name
,
12140 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12147 /* Otherwise, take the first one; there should in fact be at least
12149 c
->tb
->pass_arg_num
= 1;
12152 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12153 "must have at least one argument",
12158 me_arg
= c
->formal
->sym
;
12161 /* Now check that the argument-type matches. */
12162 gcc_assert (me_arg
);
12163 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12164 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12165 || (me_arg
->ts
.type
== BT_CLASS
12166 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12168 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12169 " the derived type '%s'", me_arg
->name
, c
->name
,
12170 me_arg
->name
, &c
->loc
, sym
->name
);
12175 /* Check for C453. */
12176 if (me_arg
->attr
.dimension
)
12178 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12179 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12185 if (me_arg
->attr
.pointer
)
12187 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12188 "may not have the POINTER attribute", me_arg
->name
,
12189 c
->name
, me_arg
->name
, &c
->loc
);
12194 if (me_arg
->attr
.allocatable
)
12196 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12197 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12198 me_arg
->name
, &c
->loc
);
12203 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12204 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12205 " at %L", c
->name
, &c
->loc
);
12209 /* Check type-spec if this is not the parent-type component. */
12210 if (((sym
->attr
.is_class
12211 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12212 || c
!= sym
->components
->ts
.u
.derived
->components
))
12213 || (!sym
->attr
.is_class
12214 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12215 && !sym
->attr
.vtype
12216 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
12219 /* If this type is an extension, set the accessibility of the parent
12222 && ((sym
->attr
.is_class
12223 && c
== sym
->components
->ts
.u
.derived
->components
)
12224 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12225 && strcmp (super_type
->name
, c
->name
) == 0)
12226 c
->attr
.access
= super_type
->attr
.access
;
12228 /* If this type is an extension, see if this component has the same name
12229 as an inherited type-bound procedure. */
12230 if (super_type
&& !sym
->attr
.is_class
12231 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12233 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12234 " inherited type-bound procedure",
12235 c
->name
, sym
->name
, &c
->loc
);
12239 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12240 && !c
->ts
.deferred
)
12242 if (c
->ts
.u
.cl
->length
== NULL
12243 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
12244 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12246 gfc_error ("Character length of component '%s' needs to "
12247 "be a constant specification expression at %L",
12249 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12254 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12255 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12257 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12258 "length must be a POINTER or ALLOCATABLE",
12259 c
->name
, sym
->name
, &c
->loc
);
12263 if (c
->ts
.type
== BT_DERIVED
12264 && sym
->component_access
!= ACCESS_PRIVATE
12265 && gfc_check_symbol_access (sym
)
12266 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12267 && !c
->ts
.u
.derived
->attr
.use_assoc
12268 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12269 && gfc_notify_std (GFC_STD_F2003
, "the component '%s' "
12270 "is a PRIVATE type and cannot be a component of "
12271 "'%s', which is PUBLIC at %L", c
->name
,
12272 sym
->name
, &sym
->declared_at
) == FAILURE
)
12275 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12277 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12278 "type %s", c
->name
, &c
->loc
, sym
->name
);
12282 if (sym
->attr
.sequence
)
12284 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12286 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12287 "not have the SEQUENCE attribute",
12288 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12293 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12294 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12295 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12296 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12297 CLASS_DATA (c
)->ts
.u
.derived
12298 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12300 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12301 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12302 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12304 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12305 "that has not been declared", c
->name
, sym
->name
,
12310 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12311 && CLASS_DATA (c
)->attr
.class_pointer
12312 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12313 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
12315 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12316 "that has not been declared", c
->name
, sym
->name
,
12322 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12323 && (!c
->attr
.class_ok
12324 || !(CLASS_DATA (c
)->attr
.class_pointer
12325 || CLASS_DATA (c
)->attr
.allocatable
)))
12327 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12328 "or pointer", c
->name
, &c
->loc
);
12332 /* Ensure that all the derived type components are put on the
12333 derived type list; even in formal namespaces, where derived type
12334 pointer components might not have been declared. */
12335 if (c
->ts
.type
== BT_DERIVED
12337 && c
->ts
.u
.derived
->components
12339 && sym
!= c
->ts
.u
.derived
)
12340 add_dt_to_dt_list (c
->ts
.u
.derived
);
12342 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
12343 || c
->attr
.proc_pointer
12344 || c
->attr
.allocatable
)) == FAILURE
)
12348 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12349 all DEFERRED bindings are overridden. */
12350 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12351 && !sym
->attr
.is_class
12352 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
12355 /* Add derived type to the derived type list. */
12356 add_dt_to_dt_list (sym
);
12362 /* The following procedure does the full resolution of a derived type,
12363 including resolution of all type-bound procedures (if present). In contrast
12364 to 'resolve_fl_derived0' this can only be done after the module has been
12365 parsed completely. */
12368 resolve_fl_derived (gfc_symbol
*sym
)
12370 gfc_symbol
*gen_dt
= NULL
;
12372 if (!sym
->attr
.is_class
)
12373 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12374 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12375 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12376 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12377 && gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of "
12378 "function '%s' at %L being the same name as derived "
12379 "type at %L", sym
->name
,
12380 gen_dt
->generic
->sym
== sym
12381 ? gen_dt
->generic
->next
->sym
->name
12382 : gen_dt
->generic
->sym
->name
,
12383 gen_dt
->generic
->sym
== sym
12384 ? &gen_dt
->generic
->next
->sym
->declared_at
12385 : &gen_dt
->generic
->sym
->declared_at
,
12386 &sym
->declared_at
) == FAILURE
)
12389 /* Resolve the finalizer procedures. */
12390 if (gfc_resolve_finalizers (sym
) == FAILURE
)
12393 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12395 /* Fix up incomplete CLASS symbols. */
12396 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12397 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12398 if (vptr
->ts
.u
.derived
== NULL
)
12400 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12402 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12406 if (resolve_fl_derived0 (sym
) == FAILURE
)
12409 /* Resolve the type-bound procedures. */
12410 if (resolve_typebound_procedures (sym
) == FAILURE
)
12418 resolve_fl_namelist (gfc_symbol
*sym
)
12423 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12425 /* Check again, the check in match only works if NAMELIST comes
12427 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12429 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12430 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12434 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12435 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
12436 "object '%s' with assumed shape in namelist "
12437 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12438 &sym
->declared_at
) == FAILURE
)
12441 if (is_non_constant_shape_array (nl
->sym
)
12442 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
12443 "object '%s' with nonconstant shape in namelist "
12444 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12445 &sym
->declared_at
) == FAILURE
)
12448 if (nl
->sym
->ts
.type
== BT_CHARACTER
12449 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12450 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12451 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
12452 "'%s' with nonconstant character length in "
12453 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
12454 &sym
->declared_at
) == FAILURE
)
12457 /* FIXME: Once UDDTIO is implemented, the following can be
12459 if (nl
->sym
->ts
.type
== BT_CLASS
)
12461 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12462 "polymorphic and requires a defined input/output "
12463 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12467 if (nl
->sym
->ts
.type
== BT_DERIVED
12468 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12469 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12471 if (gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
12472 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12473 "or POINTER components", nl
->sym
->name
,
12474 sym
->name
, &sym
->declared_at
) == FAILURE
)
12477 /* FIXME: Once UDDTIO is implemented, the following can be
12479 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12480 "ALLOCATABLE or POINTER components and thus requires "
12481 "a defined input/output procedure", nl
->sym
->name
,
12482 sym
->name
, &sym
->declared_at
);
12487 /* Reject PRIVATE objects in a PUBLIC namelist. */
12488 if (gfc_check_symbol_access (sym
))
12490 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12492 if (!nl
->sym
->attr
.use_assoc
12493 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12494 && !gfc_check_symbol_access (nl
->sym
))
12496 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12497 "cannot be member of PUBLIC namelist '%s' at %L",
12498 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12502 /* Types with private components that came here by USE-association. */
12503 if (nl
->sym
->ts
.type
== BT_DERIVED
12504 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12506 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12507 "components and cannot be member of namelist '%s' at %L",
12508 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12512 /* Types with private components that are defined in the same module. */
12513 if (nl
->sym
->ts
.type
== BT_DERIVED
12514 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12515 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12517 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12518 "cannot be a member of PUBLIC namelist '%s' at %L",
12519 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12526 /* 14.1.2 A module or internal procedure represent local entities
12527 of the same type as a namelist member and so are not allowed. */
12528 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12530 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12533 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12534 if ((nl
->sym
== sym
->ns
->proc_name
)
12536 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12541 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12542 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12544 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12545 "attribute in '%s' at %L", nlsym
->name
,
12546 &sym
->declared_at
);
12556 resolve_fl_parameter (gfc_symbol
*sym
)
12558 /* A parameter array's shape needs to be constant. */
12559 if (sym
->as
!= NULL
12560 && (sym
->as
->type
== AS_DEFERRED
12561 || is_non_constant_shape_array (sym
)))
12563 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12564 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12568 /* Make sure a parameter that has been implicitly typed still
12569 matches the implicit type, since PARAMETER statements can precede
12570 IMPLICIT statements. */
12571 if (sym
->attr
.implicit_type
12572 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12575 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12576 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12580 /* Make sure the types of derived parameters are consistent. This
12581 type checking is deferred until resolution because the type may
12582 refer to a derived type from the host. */
12583 if (sym
->ts
.type
== BT_DERIVED
12584 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12586 gfc_error ("Incompatible derived type in PARAMETER at %L",
12587 &sym
->value
->where
);
12594 /* Do anything necessary to resolve a symbol. Right now, we just
12595 assume that an otherwise unknown symbol is a variable. This sort
12596 of thing commonly happens for symbols in module. */
12599 resolve_symbol (gfc_symbol
*sym
)
12601 int check_constant
, mp_flag
;
12602 gfc_symtree
*symtree
;
12603 gfc_symtree
*this_symtree
;
12606 symbol_attribute class_attr
;
12607 gfc_array_spec
*as
;
12608 bool saved_specification_expr
;
12610 if (sym
->attr
.artificial
)
12613 if (sym
->attr
.flavor
== FL_UNKNOWN
12614 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12615 && !sym
->attr
.generic
&& !sym
->attr
.external
12616 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12619 /* If we find that a flavorless symbol is an interface in one of the
12620 parent namespaces, find its symtree in this namespace, free the
12621 symbol and set the symtree to point to the interface symbol. */
12622 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12624 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12625 if (symtree
&& (symtree
->n
.sym
->generic
||
12626 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12627 && sym
->ns
->construct_entities
)))
12629 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12631 gfc_release_symbol (sym
);
12632 symtree
->n
.sym
->refs
++;
12633 this_symtree
->n
.sym
= symtree
->n
.sym
;
12638 /* Otherwise give it a flavor according to such attributes as
12640 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12641 && sym
->attr
.intrinsic
== 0)
12642 sym
->attr
.flavor
= FL_VARIABLE
;
12643 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12645 sym
->attr
.flavor
= FL_PROCEDURE
;
12646 if (sym
->attr
.dimension
)
12647 sym
->attr
.function
= 1;
12651 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12652 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12654 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12655 && resolve_procedure_interface (sym
) == FAILURE
)
12658 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12659 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12661 if (sym
->attr
.external
)
12662 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12663 "at %L", &sym
->declared_at
);
12665 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12666 "at %L", &sym
->declared_at
);
12671 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12674 /* Symbols that are module procedures with results (functions) have
12675 the types and array specification copied for type checking in
12676 procedures that call them, as well as for saving to a module
12677 file. These symbols can't stand the scrutiny that their results
12679 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12681 /* Make sure that the intrinsic is consistent with its internal
12682 representation. This needs to be done before assigning a default
12683 type to avoid spurious warnings. */
12684 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12685 && gfc_resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12688 /* Resolve associate names. */
12690 resolve_assoc_var (sym
, true);
12692 /* Assign default type to symbols that need one and don't have one. */
12693 if (sym
->ts
.type
== BT_UNKNOWN
)
12695 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12697 gfc_set_default_type (sym
, 1, NULL
);
12700 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12701 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12702 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12703 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12705 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12707 /* The specific case of an external procedure should emit an error
12708 in the case that there is no implicit type. */
12710 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12713 /* Result may be in another namespace. */
12714 resolve_symbol (sym
->result
);
12716 if (!sym
->result
->attr
.proc_pointer
)
12718 sym
->ts
= sym
->result
->ts
;
12719 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12720 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12721 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12722 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12723 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12728 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12730 bool saved_specification_expr
= specification_expr
;
12731 specification_expr
= true;
12732 gfc_resolve_array_spec (sym
->result
->as
, false);
12733 specification_expr
= saved_specification_expr
;
12736 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12738 as
= CLASS_DATA (sym
)->as
;
12739 class_attr
= CLASS_DATA (sym
)->attr
;
12740 class_attr
.pointer
= class_attr
.class_pointer
;
12744 class_attr
= sym
->attr
;
12749 if (sym
->attr
.contiguous
12750 && (!class_attr
.dimension
12751 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12752 && !class_attr
.pointer
)))
12754 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12755 "array pointer or an assumed-shape or assumed-rank array",
12756 sym
->name
, &sym
->declared_at
);
12760 /* Assumed size arrays and assumed shape arrays must be dummy
12761 arguments. Array-spec's of implied-shape should have been resolved to
12762 AS_EXPLICIT already. */
12766 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12767 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12768 || as
->type
== AS_ASSUMED_SHAPE
)
12769 && sym
->attr
.dummy
== 0)
12771 if (as
->type
== AS_ASSUMED_SIZE
)
12772 gfc_error ("Assumed size array at %L must be a dummy argument",
12773 &sym
->declared_at
);
12775 gfc_error ("Assumed shape array at %L must be a dummy argument",
12776 &sym
->declared_at
);
12779 /* TS 29113, C535a. */
12780 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
)
12782 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12783 &sym
->declared_at
);
12786 if (as
->type
== AS_ASSUMED_RANK
12787 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12789 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12790 "CODIMENSION attribute", &sym
->declared_at
);
12795 /* Make sure symbols with known intent or optional are really dummy
12796 variable. Because of ENTRY statement, this has to be deferred
12797 until resolution time. */
12799 if (!sym
->attr
.dummy
12800 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12802 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12806 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12808 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12809 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12813 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12815 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12816 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12818 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12819 "attribute must have constant length",
12820 sym
->name
, &sym
->declared_at
);
12824 if (sym
->ts
.is_c_interop
12825 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12827 gfc_error ("C interoperable character dummy variable '%s' at %L "
12828 "with VALUE attribute must have length one",
12829 sym
->name
, &sym
->declared_at
);
12834 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12835 && sym
->ts
.u
.derived
->attr
.generic
)
12837 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12838 if (!sym
->ts
.u
.derived
)
12840 gfc_error ("The derived type '%s' at %L is of type '%s', "
12841 "which has not been defined", sym
->name
,
12842 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12843 sym
->ts
.type
= BT_UNKNOWN
;
12848 if (sym
->ts
.type
== BT_ASSUMED
)
12850 /* TS 29113, C407a. */
12851 if (!sym
->attr
.dummy
)
12853 gfc_error ("Assumed type of variable %s at %L is only permitted "
12854 "for dummy variables", sym
->name
, &sym
->declared_at
);
12857 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12858 || sym
->attr
.pointer
|| sym
->attr
.value
)
12860 gfc_error ("Assumed-type variable %s at %L may not have the "
12861 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12862 sym
->name
, &sym
->declared_at
);
12865 if (sym
->attr
.intent
== INTENT_OUT
)
12867 gfc_error ("Assumed-type variable %s at %L may not have the "
12868 "INTENT(OUT) attribute",
12869 sym
->name
, &sym
->declared_at
);
12872 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12874 gfc_error ("Assumed-type variable %s at %L shall not be an "
12875 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12880 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12881 do this for something that was implicitly typed because that is handled
12882 in gfc_set_default_type. Handle dummy arguments and procedure
12883 definitions separately. Also, anything that is use associated is not
12884 handled here but instead is handled in the module it is declared in.
12885 Finally, derived type definitions are allowed to be BIND(C) since that
12886 only implies that they're interoperable, and they are checked fully for
12887 interoperability when a variable is declared of that type. */
12888 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12889 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12890 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12892 gfc_try t
= SUCCESS
;
12894 /* First, make sure the variable is declared at the
12895 module-level scope (J3/04-007, Section 15.3). */
12896 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12897 sym
->attr
.in_common
== 0)
12899 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12900 "is neither a COMMON block nor declared at the "
12901 "module level scope", sym
->name
, &(sym
->declared_at
));
12904 else if (sym
->common_head
!= NULL
)
12906 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12910 /* If type() declaration, we need to verify that the components
12911 of the given type are all C interoperable, etc. */
12912 if (sym
->ts
.type
== BT_DERIVED
&&
12913 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12915 /* Make sure the user marked the derived type as BIND(C). If
12916 not, call the verify routine. This could print an error
12917 for the derived type more than once if multiple variables
12918 of that type are declared. */
12919 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12920 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12924 /* Verify the variable itself as C interoperable if it
12925 is BIND(C). It is not possible for this to succeed if
12926 the verify_bind_c_derived_type failed, so don't have to handle
12927 any error returned by verify_bind_c_derived_type. */
12928 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12929 sym
->common_block
);
12934 /* clear the is_bind_c flag to prevent reporting errors more than
12935 once if something failed. */
12936 sym
->attr
.is_bind_c
= 0;
12941 /* If a derived type symbol has reached this point, without its
12942 type being declared, we have an error. Notice that most
12943 conditions that produce undefined derived types have already
12944 been dealt with. However, the likes of:
12945 implicit type(t) (t) ..... call foo (t) will get us here if
12946 the type is not declared in the scope of the implicit
12947 statement. Change the type to BT_UNKNOWN, both because it is so
12948 and to prevent an ICE. */
12949 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12950 && sym
->ts
.u
.derived
->components
== NULL
12951 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12953 gfc_error ("The derived type '%s' at %L is of type '%s', "
12954 "which has not been defined", sym
->name
,
12955 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12956 sym
->ts
.type
= BT_UNKNOWN
;
12960 /* Make sure that the derived type has been resolved and that the
12961 derived type is visible in the symbol's namespace, if it is a
12962 module function and is not PRIVATE. */
12963 if (sym
->ts
.type
== BT_DERIVED
12964 && sym
->ts
.u
.derived
->attr
.use_assoc
12965 && sym
->ns
->proc_name
12966 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12967 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12970 /* Unless the derived-type declaration is use associated, Fortran 95
12971 does not allow public entries of private derived types.
12972 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12973 161 in 95-006r3. */
12974 if (sym
->ts
.type
== BT_DERIVED
12975 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12976 && !sym
->ts
.u
.derived
->attr
.use_assoc
12977 && gfc_check_symbol_access (sym
)
12978 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12979 && gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L "
12980 "of PRIVATE derived type '%s'",
12981 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12982 : "variable", sym
->name
, &sym
->declared_at
,
12983 sym
->ts
.u
.derived
->name
) == FAILURE
)
12986 /* F2008, C1302. */
12987 if (sym
->ts
.type
== BT_DERIVED
12988 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12989 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12990 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12991 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12993 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12994 "type LOCK_TYPE must be a coarray", sym
->name
,
12995 &sym
->declared_at
);
12999 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
13000 default initialization is defined (5.1.2.4.4). */
13001 if (sym
->ts
.type
== BT_DERIVED
13003 && sym
->attr
.intent
== INTENT_OUT
13005 && sym
->as
->type
== AS_ASSUMED_SIZE
)
13007 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
13009 if (c
->initializer
)
13011 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
13012 "ASSUMED SIZE and so cannot have a default initializer",
13013 sym
->name
, &sym
->declared_at
);
13020 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
13021 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
13023 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
13024 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
13029 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13030 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13031 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13032 || class_attr
.codimension
)
13033 && (sym
->attr
.result
|| sym
->result
== sym
))
13035 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
13036 "a coarray component", sym
->name
, &sym
->declared_at
);
13041 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
13042 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
13044 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
13045 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
13050 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13051 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13052 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13053 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
13054 || class_attr
.allocatable
))
13056 gfc_error ("Variable '%s' at %L with coarray component "
13057 "shall be a nonpointer, nonallocatable scalar",
13058 sym
->name
, &sym
->declared_at
);
13062 /* F2008, C526. The function-result case was handled above. */
13063 if (class_attr
.codimension
13064 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
13065 || sym
->attr
.select_type_temporary
13066 || sym
->ns
->save_all
13067 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13068 || sym
->ns
->proc_name
->attr
.is_main_program
13069 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13071 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13072 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13076 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13077 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13079 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13080 "deferred shape", sym
->name
, &sym
->declared_at
);
13083 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13084 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13086 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13087 "deferred shape", sym
->name
, &sym
->declared_at
);
13092 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13093 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13094 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13095 || (class_attr
.codimension
&& class_attr
.allocatable
))
13096 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13098 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13099 "allocatable coarray or have coarray components",
13100 sym
->name
, &sym
->declared_at
);
13104 if (class_attr
.codimension
&& sym
->attr
.dummy
13105 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13107 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13108 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13109 sym
->ns
->proc_name
->name
);
13113 switch (sym
->attr
.flavor
)
13116 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
13121 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
13126 if (resolve_fl_namelist (sym
) == FAILURE
)
13131 if (resolve_fl_parameter (sym
) == FAILURE
)
13139 /* Resolve array specifier. Check as well some constraints
13140 on COMMON blocks. */
13142 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13144 /* Set the formal_arg_flag so that check_conflict will not throw
13145 an error for host associated variables in the specification
13146 expression for an array_valued function. */
13147 if (sym
->attr
.function
&& sym
->as
)
13148 formal_arg_flag
= 1;
13150 saved_specification_expr
= specification_expr
;
13151 specification_expr
= true;
13152 gfc_resolve_array_spec (sym
->as
, check_constant
);
13153 specification_expr
= saved_specification_expr
;
13155 formal_arg_flag
= 0;
13157 /* Resolve formal namespaces. */
13158 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13159 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13160 gfc_resolve (sym
->formal_ns
);
13162 /* Make sure the formal namespace is present. */
13163 if (sym
->formal
&& !sym
->formal_ns
)
13165 gfc_formal_arglist
*formal
= sym
->formal
;
13166 while (formal
&& !formal
->sym
)
13167 formal
= formal
->next
;
13171 sym
->formal_ns
= formal
->sym
->ns
;
13172 if (sym
->ns
!= formal
->sym
->ns
)
13173 sym
->formal_ns
->refs
++;
13177 /* Check threadprivate restrictions. */
13178 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13179 && (!sym
->attr
.in_common
13180 && sym
->module
== NULL
13181 && (sym
->ns
->proc_name
== NULL
13182 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13183 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13185 /* If we have come this far we can apply default-initializers, as
13186 described in 14.7.5, to those variables that have not already
13187 been assigned one. */
13188 if (sym
->ts
.type
== BT_DERIVED
13189 && sym
->ns
== gfc_current_ns
13191 && !sym
->attr
.allocatable
13192 && !sym
->attr
.alloc_comp
)
13194 symbol_attribute
*a
= &sym
->attr
;
13196 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13197 && !a
->in_common
&& !a
->use_assoc
13198 && (a
->referenced
|| a
->result
)
13199 && !(a
->function
&& sym
!= sym
->result
))
13200 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13201 apply_default_init (sym
);
13204 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13205 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13206 && !CLASS_DATA (sym
)->attr
.class_pointer
13207 && !CLASS_DATA (sym
)->attr
.allocatable
)
13208 apply_default_init (sym
);
13210 /* If this symbol has a type-spec, check it. */
13211 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13212 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13213 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
13219 /************* Resolve DATA statements *************/
13223 gfc_data_value
*vnode
;
13229 /* Advance the values structure to point to the next value in the data list. */
13232 next_data_value (void)
13234 while (mpz_cmp_ui (values
.left
, 0) == 0)
13237 if (values
.vnode
->next
== NULL
)
13240 values
.vnode
= values
.vnode
->next
;
13241 mpz_set (values
.left
, values
.vnode
->repeat
);
13249 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13255 ar_type mark
= AR_UNKNOWN
;
13257 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13263 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
13267 mpz_init_set_si (offset
, 0);
13270 if (e
->expr_type
!= EXPR_VARIABLE
)
13271 gfc_internal_error ("check_data_variable(): Bad expression");
13273 sym
= e
->symtree
->n
.sym
;
13275 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13277 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13278 sym
->name
, &sym
->declared_at
);
13281 if (e
->ref
== NULL
&& sym
->as
)
13283 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13284 " declaration", sym
->name
, where
);
13288 has_pointer
= sym
->attr
.pointer
;
13290 if (gfc_is_coindexed (e
))
13292 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13297 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13299 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13303 && ref
->type
== REF_ARRAY
13304 && ref
->u
.ar
.type
!= AR_FULL
)
13306 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13307 "be a full array", sym
->name
, where
);
13312 if (e
->rank
== 0 || has_pointer
)
13314 mpz_init_set_ui (size
, 1);
13321 /* Find the array section reference. */
13322 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13324 if (ref
->type
!= REF_ARRAY
)
13326 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13332 /* Set marks according to the reference pattern. */
13333 switch (ref
->u
.ar
.type
)
13341 /* Get the start position of array section. */
13342 gfc_get_section_index (ar
, section_index
, &offset
);
13347 gcc_unreachable ();
13350 if (gfc_array_size (e
, &size
) == FAILURE
)
13352 gfc_error ("Nonconstant array section at %L in DATA statement",
13354 mpz_clear (offset
);
13361 while (mpz_cmp_ui (size
, 0) > 0)
13363 if (next_data_value () == FAILURE
)
13365 gfc_error ("DATA statement at %L has more variables than values",
13371 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13375 /* If we have more than one element left in the repeat count,
13376 and we have more than one element left in the target variable,
13377 then create a range assignment. */
13378 /* FIXME: Only done for full arrays for now, since array sections
13380 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13381 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13385 if (mpz_cmp (size
, values
.left
) >= 0)
13387 mpz_init_set (range
, values
.left
);
13388 mpz_sub (size
, size
, values
.left
);
13389 mpz_set_ui (values
.left
, 0);
13393 mpz_init_set (range
, size
);
13394 mpz_sub (values
.left
, values
.left
, size
);
13395 mpz_set_ui (size
, 0);
13398 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13401 mpz_add (offset
, offset
, range
);
13408 /* Assign initial value to symbol. */
13411 mpz_sub_ui (values
.left
, values
.left
, 1);
13412 mpz_sub_ui (size
, size
, 1);
13414 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13419 if (mark
== AR_FULL
)
13420 mpz_add_ui (offset
, offset
, 1);
13422 /* Modify the array section indexes and recalculate the offset
13423 for next element. */
13424 else if (mark
== AR_SECTION
)
13425 gfc_advance_section (section_index
, ar
, &offset
);
13429 if (mark
== AR_SECTION
)
13431 for (i
= 0; i
< ar
->dimen
; i
++)
13432 mpz_clear (section_index
[i
]);
13436 mpz_clear (offset
);
13442 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
13444 /* Iterate over a list of elements in a DATA statement. */
13447 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13450 iterator_stack frame
;
13451 gfc_expr
*e
, *start
, *end
, *step
;
13452 gfc_try retval
= SUCCESS
;
13454 mpz_init (frame
.value
);
13457 start
= gfc_copy_expr (var
->iter
.start
);
13458 end
= gfc_copy_expr (var
->iter
.end
);
13459 step
= gfc_copy_expr (var
->iter
.step
);
13461 if (gfc_simplify_expr (start
, 1) == FAILURE
13462 || start
->expr_type
!= EXPR_CONSTANT
)
13464 gfc_error ("start of implied-do loop at %L could not be "
13465 "simplified to a constant value", &start
->where
);
13469 if (gfc_simplify_expr (end
, 1) == FAILURE
13470 || end
->expr_type
!= EXPR_CONSTANT
)
13472 gfc_error ("end of implied-do loop at %L could not be "
13473 "simplified to a constant value", &start
->where
);
13477 if (gfc_simplify_expr (step
, 1) == FAILURE
13478 || step
->expr_type
!= EXPR_CONSTANT
)
13480 gfc_error ("step of implied-do loop at %L could not be "
13481 "simplified to a constant value", &start
->where
);
13486 mpz_set (trip
, end
->value
.integer
);
13487 mpz_sub (trip
, trip
, start
->value
.integer
);
13488 mpz_add (trip
, trip
, step
->value
.integer
);
13490 mpz_div (trip
, trip
, step
->value
.integer
);
13492 mpz_set (frame
.value
, start
->value
.integer
);
13494 frame
.prev
= iter_stack
;
13495 frame
.variable
= var
->iter
.var
->symtree
;
13496 iter_stack
= &frame
;
13498 while (mpz_cmp_ui (trip
, 0) > 0)
13500 if (traverse_data_var (var
->list
, where
) == FAILURE
)
13506 e
= gfc_copy_expr (var
->expr
);
13507 if (gfc_simplify_expr (e
, 1) == FAILURE
)
13514 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13516 mpz_sub_ui (trip
, trip
, 1);
13520 mpz_clear (frame
.value
);
13523 gfc_free_expr (start
);
13524 gfc_free_expr (end
);
13525 gfc_free_expr (step
);
13527 iter_stack
= frame
.prev
;
13532 /* Type resolve variables in the variable list of a DATA statement. */
13535 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13539 for (; var
; var
= var
->next
)
13541 if (var
->expr
== NULL
)
13542 t
= traverse_data_list (var
, where
);
13544 t
= check_data_variable (var
, where
);
13554 /* Resolve the expressions and iterators associated with a data statement.
13555 This is separate from the assignment checking because data lists should
13556 only be resolved once. */
13559 resolve_data_variables (gfc_data_variable
*d
)
13561 for (; d
; d
= d
->next
)
13563 if (d
->list
== NULL
)
13565 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
13570 if (gfc_resolve_iterator (&d
->iter
, false, true) == FAILURE
)
13573 if (resolve_data_variables (d
->list
) == FAILURE
)
13582 /* Resolve a single DATA statement. We implement this by storing a pointer to
13583 the value list into static variables, and then recursively traversing the
13584 variables list, expanding iterators and such. */
13587 resolve_data (gfc_data
*d
)
13590 if (resolve_data_variables (d
->var
) == FAILURE
)
13593 values
.vnode
= d
->value
;
13594 if (d
->value
== NULL
)
13595 mpz_set_ui (values
.left
, 0);
13597 mpz_set (values
.left
, d
->value
->repeat
);
13599 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13602 /* At this point, we better not have any values left. */
13604 if (next_data_value () == SUCCESS
)
13605 gfc_error ("DATA statement at %L has more values than variables",
13610 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13611 accessed by host or use association, is a dummy argument to a pure function,
13612 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13613 is storage associated with any such variable, shall not be used in the
13614 following contexts: (clients of this function). */
13616 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13617 procedure. Returns zero if assignment is OK, nonzero if there is a
13620 gfc_impure_variable (gfc_symbol
*sym
)
13625 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13628 /* Check if the symbol's ns is inside the pure procedure. */
13629 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13633 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13637 proc
= sym
->ns
->proc_name
;
13638 if (sym
->attr
.dummy
13639 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13640 || proc
->attr
.function
))
13643 /* TODO: Sort out what can be storage associated, if anything, and include
13644 it here. In principle equivalences should be scanned but it does not
13645 seem to be possible to storage associate an impure variable this way. */
13650 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13651 current namespace is inside a pure procedure. */
13654 gfc_pure (gfc_symbol
*sym
)
13656 symbol_attribute attr
;
13661 /* Check if the current namespace or one of its parents
13662 belongs to a pure procedure. */
13663 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13665 sym
= ns
->proc_name
;
13669 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13677 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13681 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13682 checks if the current namespace is implicitly pure. Note that this
13683 function returns false for a PURE procedure. */
13686 gfc_implicit_pure (gfc_symbol
*sym
)
13692 /* Check if the current procedure is implicit_pure. Walk up
13693 the procedure list until we find a procedure. */
13694 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13696 sym
= ns
->proc_name
;
13700 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13705 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13706 && !sym
->attr
.pure
;
13710 /* Test whether the current procedure is elemental or not. */
13713 gfc_elemental (gfc_symbol
*sym
)
13715 symbol_attribute attr
;
13718 sym
= gfc_current_ns
->proc_name
;
13723 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13727 /* Warn about unused labels. */
13730 warn_unused_fortran_label (gfc_st_label
*label
)
13735 warn_unused_fortran_label (label
->left
);
13737 if (label
->defined
== ST_LABEL_UNKNOWN
)
13740 switch (label
->referenced
)
13742 case ST_LABEL_UNKNOWN
:
13743 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13747 case ST_LABEL_BAD_TARGET
:
13748 gfc_warning ("Label %d at %L defined but cannot be used",
13749 label
->value
, &label
->where
);
13756 warn_unused_fortran_label (label
->right
);
13760 /* Returns the sequence type of a symbol or sequence. */
13763 sequence_type (gfc_typespec ts
)
13772 if (ts
.u
.derived
->components
== NULL
)
13773 return SEQ_NONDEFAULT
;
13775 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13776 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13777 if (sequence_type (c
->ts
) != result
)
13783 if (ts
.kind
!= gfc_default_character_kind
)
13784 return SEQ_NONDEFAULT
;
13786 return SEQ_CHARACTER
;
13789 if (ts
.kind
!= gfc_default_integer_kind
)
13790 return SEQ_NONDEFAULT
;
13792 return SEQ_NUMERIC
;
13795 if (!(ts
.kind
== gfc_default_real_kind
13796 || ts
.kind
== gfc_default_double_kind
))
13797 return SEQ_NONDEFAULT
;
13799 return SEQ_NUMERIC
;
13802 if (ts
.kind
!= gfc_default_complex_kind
)
13803 return SEQ_NONDEFAULT
;
13805 return SEQ_NUMERIC
;
13808 if (ts
.kind
!= gfc_default_logical_kind
)
13809 return SEQ_NONDEFAULT
;
13811 return SEQ_NUMERIC
;
13814 return SEQ_NONDEFAULT
;
13819 /* Resolve derived type EQUIVALENCE object. */
13822 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13824 gfc_component
*c
= derived
->components
;
13829 /* Shall not be an object of nonsequence derived type. */
13830 if (!derived
->attr
.sequence
)
13832 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13833 "attribute to be an EQUIVALENCE object", sym
->name
,
13838 /* Shall not have allocatable components. */
13839 if (derived
->attr
.alloc_comp
)
13841 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13842 "components to be an EQUIVALENCE object",sym
->name
,
13847 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13849 gfc_error ("Derived type variable '%s' at %L with default "
13850 "initialization cannot be in EQUIVALENCE with a variable "
13851 "in COMMON", sym
->name
, &e
->where
);
13855 for (; c
; c
= c
->next
)
13857 if (c
->ts
.type
== BT_DERIVED
13858 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13861 /* Shall not be an object of sequence derived type containing a pointer
13862 in the structure. */
13863 if (c
->attr
.pointer
)
13865 gfc_error ("Derived type variable '%s' at %L with pointer "
13866 "component(s) cannot be an EQUIVALENCE object",
13867 sym
->name
, &e
->where
);
13875 /* Resolve equivalence object.
13876 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13877 an allocatable array, an object of nonsequence derived type, an object of
13878 sequence derived type containing a pointer at any level of component
13879 selection, an automatic object, a function name, an entry name, a result
13880 name, a named constant, a structure component, or a subobject of any of
13881 the preceding objects. A substring shall not have length zero. A
13882 derived type shall not have components with default initialization nor
13883 shall two objects of an equivalence group be initialized.
13884 Either all or none of the objects shall have an protected attribute.
13885 The simple constraints are done in symbol.c(check_conflict) and the rest
13886 are implemented here. */
13889 resolve_equivalence (gfc_equiv
*eq
)
13892 gfc_symbol
*first_sym
;
13895 locus
*last_where
= NULL
;
13896 seq_type eq_type
, last_eq_type
;
13897 gfc_typespec
*last_ts
;
13898 int object
, cnt_protected
;
13901 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13903 first_sym
= eq
->expr
->symtree
->n
.sym
;
13907 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13911 e
->ts
= e
->symtree
->n
.sym
->ts
;
13912 /* match_varspec might not know yet if it is seeing
13913 array reference or substring reference, as it doesn't
13915 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13917 gfc_ref
*ref
= e
->ref
;
13918 sym
= e
->symtree
->n
.sym
;
13920 if (sym
->attr
.dimension
)
13922 ref
->u
.ar
.as
= sym
->as
;
13926 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13927 if (e
->ts
.type
== BT_CHARACTER
13929 && ref
->type
== REF_ARRAY
13930 && ref
->u
.ar
.dimen
== 1
13931 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13932 && ref
->u
.ar
.stride
[0] == NULL
)
13934 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13935 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13938 /* Optimize away the (:) reference. */
13939 if (start
== NULL
&& end
== NULL
)
13942 e
->ref
= ref
->next
;
13944 e
->ref
->next
= ref
->next
;
13949 ref
->type
= REF_SUBSTRING
;
13951 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13953 ref
->u
.ss
.start
= start
;
13954 if (end
== NULL
&& e
->ts
.u
.cl
)
13955 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13956 ref
->u
.ss
.end
= end
;
13957 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13964 /* Any further ref is an error. */
13967 gcc_assert (ref
->type
== REF_ARRAY
);
13968 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13974 if (gfc_resolve_expr (e
) == FAILURE
)
13977 sym
= e
->symtree
->n
.sym
;
13979 if (sym
->attr
.is_protected
)
13981 if (cnt_protected
> 0 && cnt_protected
!= object
)
13983 gfc_error ("Either all or none of the objects in the "
13984 "EQUIVALENCE set at %L shall have the "
13985 "PROTECTED attribute",
13990 /* Shall not equivalence common block variables in a PURE procedure. */
13991 if (sym
->ns
->proc_name
13992 && sym
->ns
->proc_name
->attr
.pure
13993 && sym
->attr
.in_common
)
13995 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13996 "object in the pure procedure '%s'",
13997 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
14001 /* Shall not be a named constant. */
14002 if (e
->expr_type
== EXPR_CONSTANT
)
14004 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
14005 "object", sym
->name
, &e
->where
);
14009 if (e
->ts
.type
== BT_DERIVED
14010 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
14013 /* Check that the types correspond correctly:
14015 A numeric sequence structure may be equivalenced to another sequence
14016 structure, an object of default integer type, default real type, double
14017 precision real type, default logical type such that components of the
14018 structure ultimately only become associated to objects of the same
14019 kind. A character sequence structure may be equivalenced to an object
14020 of default character kind or another character sequence structure.
14021 Other objects may be equivalenced only to objects of the same type and
14022 kind parameters. */
14024 /* Identical types are unconditionally OK. */
14025 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
14026 goto identical_types
;
14028 last_eq_type
= sequence_type (*last_ts
);
14029 eq_type
= sequence_type (sym
->ts
);
14031 /* Since the pair of objects is not of the same type, mixed or
14032 non-default sequences can be rejected. */
14034 msg
= "Sequence %s with mixed components in EQUIVALENCE "
14035 "statement at %L with different type objects";
14037 && last_eq_type
== SEQ_MIXED
14038 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
14040 || (eq_type
== SEQ_MIXED
14041 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14042 &e
->where
) == FAILURE
))
14045 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
14046 "statement at %L with objects of different type";
14048 && last_eq_type
== SEQ_NONDEFAULT
14049 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
14050 last_where
) == FAILURE
)
14051 || (eq_type
== SEQ_NONDEFAULT
14052 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14053 &e
->where
) == FAILURE
))
14056 msg
="Non-CHARACTER object '%s' in default CHARACTER "
14057 "EQUIVALENCE statement at %L";
14058 if (last_eq_type
== SEQ_CHARACTER
14059 && eq_type
!= SEQ_CHARACTER
14060 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14061 &e
->where
) == FAILURE
)
14064 msg
="Non-NUMERIC object '%s' in default NUMERIC "
14065 "EQUIVALENCE statement at %L";
14066 if (last_eq_type
== SEQ_NUMERIC
14067 && eq_type
!= SEQ_NUMERIC
14068 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14069 &e
->where
) == FAILURE
)
14074 last_where
= &e
->where
;
14079 /* Shall not be an automatic array. */
14080 if (e
->ref
->type
== REF_ARRAY
14081 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
14083 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14084 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14091 /* Shall not be a structure component. */
14092 if (r
->type
== REF_COMPONENT
)
14094 gfc_error ("Structure component '%s' at %L cannot be an "
14095 "EQUIVALENCE object",
14096 r
->u
.c
.component
->name
, &e
->where
);
14100 /* A substring shall not have length zero. */
14101 if (r
->type
== REF_SUBSTRING
)
14103 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14105 gfc_error ("Substring at %L has length zero",
14106 &r
->u
.ss
.start
->where
);
14116 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14119 resolve_fntype (gfc_namespace
*ns
)
14121 gfc_entry_list
*el
;
14124 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14127 /* If there are any entries, ns->proc_name is the entry master
14128 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14130 sym
= ns
->entries
->sym
;
14132 sym
= ns
->proc_name
;
14133 if (sym
->result
== sym
14134 && sym
->ts
.type
== BT_UNKNOWN
14135 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
14136 && !sym
->attr
.untyped
)
14138 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14139 sym
->name
, &sym
->declared_at
);
14140 sym
->attr
.untyped
= 1;
14143 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14144 && !sym
->attr
.contained
14145 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14146 && gfc_check_symbol_access (sym
))
14148 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14149 "%L of PRIVATE type '%s'", sym
->name
,
14150 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14154 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14156 if (el
->sym
->result
== el
->sym
14157 && el
->sym
->ts
.type
== BT_UNKNOWN
14158 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
14159 && !el
->sym
->attr
.untyped
)
14161 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14162 el
->sym
->name
, &el
->sym
->declared_at
);
14163 el
->sym
->attr
.untyped
= 1;
14169 /* 12.3.2.1.1 Defined operators. */
14172 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14174 gfc_formal_arglist
*formal
;
14176 if (!sym
->attr
.function
)
14178 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14179 sym
->name
, &where
);
14183 if (sym
->ts
.type
== BT_CHARACTER
14184 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14185 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14186 && sym
->result
->ts
.u
.cl
->length
))
14188 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14189 "character length", sym
->name
, &where
);
14193 formal
= sym
->formal
;
14194 if (!formal
|| !formal
->sym
)
14196 gfc_error ("User operator procedure '%s' at %L must have at least "
14197 "one argument", sym
->name
, &where
);
14201 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14203 gfc_error ("First argument of operator interface at %L must be "
14204 "INTENT(IN)", &where
);
14208 if (formal
->sym
->attr
.optional
)
14210 gfc_error ("First argument of operator interface at %L cannot be "
14211 "optional", &where
);
14215 formal
= formal
->next
;
14216 if (!formal
|| !formal
->sym
)
14219 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14221 gfc_error ("Second argument of operator interface at %L must be "
14222 "INTENT(IN)", &where
);
14226 if (formal
->sym
->attr
.optional
)
14228 gfc_error ("Second argument of operator interface at %L cannot be "
14229 "optional", &where
);
14235 gfc_error ("Operator interface at %L must have, at most, two "
14236 "arguments", &where
);
14244 gfc_resolve_uops (gfc_symtree
*symtree
)
14246 gfc_interface
*itr
;
14248 if (symtree
== NULL
)
14251 gfc_resolve_uops (symtree
->left
);
14252 gfc_resolve_uops (symtree
->right
);
14254 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14255 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14259 /* Examine all of the expressions associated with a program unit,
14260 assign types to all intermediate expressions, make sure that all
14261 assignments are to compatible types and figure out which names
14262 refer to which functions or subroutines. It doesn't check code
14263 block, which is handled by resolve_code. */
14266 resolve_types (gfc_namespace
*ns
)
14272 gfc_namespace
* old_ns
= gfc_current_ns
;
14274 /* Check that all IMPLICIT types are ok. */
14275 if (!ns
->seen_implicit_none
)
14278 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14279 if (ns
->set_flag
[letter
]
14280 && resolve_typespec_used (&ns
->default_type
[letter
],
14281 &ns
->implicit_loc
[letter
],
14286 gfc_current_ns
= ns
;
14288 resolve_entries (ns
);
14290 resolve_common_vars (ns
->blank_common
.head
, false);
14291 resolve_common_blocks (ns
->common_root
);
14293 resolve_contained_functions (ns
);
14295 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14296 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14297 resolve_formal_arglist (ns
->proc_name
);
14299 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14301 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14302 resolve_charlen (cl
);
14304 gfc_traverse_ns (ns
, resolve_symbol
);
14306 resolve_fntype (ns
);
14308 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14310 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14311 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14312 "also be PURE", n
->proc_name
->name
,
14313 &n
->proc_name
->declared_at
);
14319 do_concurrent_flag
= 0;
14320 gfc_check_interfaces (ns
);
14322 gfc_traverse_ns (ns
, resolve_values
);
14328 for (d
= ns
->data
; d
; d
= d
->next
)
14332 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14334 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14336 if (ns
->common_root
!= NULL
)
14337 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
14339 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14340 resolve_equivalence (eq
);
14342 /* Warn about unused labels. */
14343 if (warn_unused_label
)
14344 warn_unused_fortran_label (ns
->st_labels
);
14346 gfc_resolve_uops (ns
->uop_root
);
14348 gfc_current_ns
= old_ns
;
14352 /* Call resolve_code recursively. */
14355 resolve_codes (gfc_namespace
*ns
)
14358 bitmap_obstack old_obstack
;
14360 if (ns
->resolved
== 1)
14363 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14366 gfc_current_ns
= ns
;
14368 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14369 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14372 /* Set to an out of range value. */
14373 current_entry_id
= -1;
14375 old_obstack
= labels_obstack
;
14376 bitmap_obstack_initialize (&labels_obstack
);
14378 resolve_code (ns
->code
, ns
);
14380 bitmap_obstack_release (&labels_obstack
);
14381 labels_obstack
= old_obstack
;
14385 /* This function is called after a complete program unit has been compiled.
14386 Its purpose is to examine all of the expressions associated with a program
14387 unit, assign types to all intermediate expressions, make sure that all
14388 assignments are to compatible types and figure out which names refer to
14389 which functions or subroutines. */
14392 gfc_resolve (gfc_namespace
*ns
)
14394 gfc_namespace
*old_ns
;
14395 code_stack
*old_cs_base
;
14401 old_ns
= gfc_current_ns
;
14402 old_cs_base
= cs_base
;
14404 resolve_types (ns
);
14405 resolve_codes (ns
);
14407 gfc_current_ns
= old_ns
;
14408 cs_base
= old_cs_base
;
14411 gfc_run_passes (ns
);