1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
30 #include "arith.h" /* For gfc_compare_expr(). */
31 #include "dependency.h"
33 #include "target-memory.h" /* for gfc_simplify_transfer */
34 #include "constructor.h"
36 /* Types used in equivalence statements. */
40 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
44 /* Stack to keep track of the nesting of blocks as we move through the
45 code. See resolve_branch() and resolve_code(). */
47 typedef struct code_stack
49 struct gfc_code
*head
, *current
;
50 struct code_stack
*prev
;
52 /* This bitmap keeps track of the targets valid for a branch from
53 inside this block except for END {IF|SELECT}s of enclosing
55 bitmap reachable_labels
;
59 static code_stack
*cs_base
= NULL
;
62 /* Nonzero if we're inside a FORALL or DO CONCURRENT block. */
64 static int forall_flag
;
65 static int do_concurrent_flag
;
67 /* True when we are resolving an expression that is an actual argument to
69 static bool actual_arg
= false;
70 /* True when we are resolving an expression that is the first actual argument
72 static bool first_actual_arg
= false;
75 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
77 static int omp_workshare_flag
;
79 /* Nonzero if we are processing a formal arglist. The corresponding function
80 resets the flag each time that it is read. */
81 static int formal_arg_flag
= 0;
83 /* True if we are resolving a specification expression. */
84 static int specification_expr
= 0;
86 /* The id of the last entry seen. */
87 static int current_entry_id
;
89 /* We use bitmaps to determine if a branch target is valid. */
90 static bitmap_obstack labels_obstack
;
92 /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
93 static bool inquiry_argument
= false;
97 gfc_is_formal_arg (void)
99 return formal_arg_flag
;
102 /* Is the symbol host associated? */
104 is_sym_host_assoc (gfc_symbol
*sym
, gfc_namespace
*ns
)
106 for (ns
= ns
->parent
; ns
; ns
= ns
->parent
)
115 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
116 an ABSTRACT derived-type. If where is not NULL, an error message with that
117 locus is printed, optionally using name. */
120 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
122 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
->attr
.abstract
)
127 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
128 name
, where
, ts
->u
.derived
->name
);
130 gfc_error ("ABSTRACT type '%s' used at %L",
131 ts
->u
.derived
->name
, where
);
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
;
283 if (proc
->result
!= NULL
)
288 if (gfc_elemental (proc
)
289 || sym
->attr
.pointer
|| sym
->attr
.allocatable
290 || (sym
->as
&& sym
->as
->rank
!= 0))
292 proc
->attr
.always_explicit
= 1;
293 sym
->attr
.always_explicit
= 1;
298 for (f
= proc
->formal
; f
; f
= f
->next
)
306 /* Alternate return placeholder. */
307 if (gfc_elemental (proc
))
308 gfc_error ("Alternate return specifier in elemental subroutine "
309 "'%s' at %L is not allowed", proc
->name
,
311 if (proc
->attr
.function
)
312 gfc_error ("Alternate return specifier in function "
313 "'%s' at %L is not allowed", proc
->name
,
317 else if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
318 && resolve_procedure_interface (sym
) == FAILURE
)
321 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
322 resolve_formal_arglist (sym
);
324 if (sym
->attr
.subroutine
|| sym
->attr
.external
)
326 if (sym
->attr
.flavor
== FL_UNKNOWN
)
327 gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, &sym
->declared_at
);
331 if (sym
->ts
.type
== BT_UNKNOWN
&& !proc
->attr
.intrinsic
332 && (!sym
->attr
.function
|| sym
->result
== sym
))
333 gfc_set_default_type (sym
, 1, sym
->ns
);
336 as
= sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
337 ? CLASS_DATA (sym
)->as
: sym
->as
;
339 gfc_resolve_array_spec (as
, 0);
341 /* We can't tell if an array with dimension (:) is assumed or deferred
342 shape until we know if it has the pointer or allocatable attributes.
344 if (as
&& as
->rank
> 0 && as
->type
== AS_DEFERRED
345 && ((sym
->ts
.type
!= BT_CLASS
346 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
347 || (sym
->ts
.type
== BT_CLASS
348 && !(CLASS_DATA (sym
)->attr
.class_pointer
349 || CLASS_DATA (sym
)->attr
.allocatable
)))
350 && sym
->attr
.flavor
!= FL_PROCEDURE
)
352 as
->type
= AS_ASSUMED_SHAPE
;
353 for (i
= 0; i
< as
->rank
; i
++)
354 as
->lower
[i
] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
357 if ((as
&& as
->rank
> 0 && as
->type
== AS_ASSUMED_SHAPE
)
358 || (as
&& as
->type
== AS_ASSUMED_RANK
)
359 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
360 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
361 && (CLASS_DATA (sym
)->attr
.class_pointer
362 || CLASS_DATA (sym
)->attr
.allocatable
363 || CLASS_DATA (sym
)->attr
.target
))
364 || sym
->attr
.optional
)
366 proc
->attr
.always_explicit
= 1;
368 proc
->result
->attr
.always_explicit
= 1;
371 /* If the flavor is unknown at this point, it has to be a variable.
372 A procedure specification would have already set the type. */
374 if (sym
->attr
.flavor
== FL_UNKNOWN
)
375 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
379 if (sym
->attr
.flavor
== FL_PROCEDURE
)
384 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
385 "also be PURE", sym
->name
, &sym
->declared_at
);
389 else if (!sym
->attr
.pointer
)
391 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
394 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
395 " of pure function '%s' at %L with VALUE "
396 "attribute but without INTENT(IN)",
397 sym
->name
, proc
->name
, &sym
->declared_at
);
399 gfc_error ("Argument '%s' of pure function '%s' at %L must "
400 "be INTENT(IN) or VALUE", sym
->name
, proc
->name
,
404 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
407 gfc_notify_std (GFC_STD_F2008
, "Argument '%s'"
408 " of pure subroutine '%s' at %L with VALUE "
409 "attribute but without INTENT", sym
->name
,
410 proc
->name
, &sym
->declared_at
);
412 gfc_error ("Argument '%s' of pure subroutine '%s' at %L "
413 "must have its INTENT specified or have the "
414 "VALUE attribute", sym
->name
, proc
->name
,
420 if (proc
->attr
.implicit_pure
)
422 if (sym
->attr
.flavor
== FL_PROCEDURE
)
425 proc
->attr
.implicit_pure
= 0;
427 else if (!sym
->attr
.pointer
)
429 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
430 proc
->attr
.implicit_pure
= 0;
432 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
433 proc
->attr
.implicit_pure
= 0;
437 if (gfc_elemental (proc
))
440 if (sym
->attr
.codimension
441 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
442 && CLASS_DATA (sym
)->attr
.codimension
))
444 gfc_error ("Coarray dummy argument '%s' at %L to elemental "
445 "procedure", sym
->name
, &sym
->declared_at
);
449 if (sym
->as
|| (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
450 && CLASS_DATA (sym
)->as
))
452 gfc_error ("Argument '%s' of elemental procedure at %L must "
453 "be scalar", sym
->name
, &sym
->declared_at
);
457 if (sym
->attr
.allocatable
458 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
459 && CLASS_DATA (sym
)->attr
.allocatable
))
461 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
462 "have the ALLOCATABLE attribute", sym
->name
,
467 if (sym
->attr
.pointer
468 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
469 && CLASS_DATA (sym
)->attr
.class_pointer
))
471 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
472 "have the POINTER attribute", sym
->name
,
477 if (sym
->attr
.flavor
== FL_PROCEDURE
)
479 gfc_error ("Dummy procedure '%s' not allowed in elemental "
480 "procedure '%s' at %L", sym
->name
, proc
->name
,
485 if (sym
->attr
.intent
== INTENT_UNKNOWN
)
487 gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
488 "have its INTENT specified", sym
->name
, proc
->name
,
494 /* Each dummy shall be specified to be scalar. */
495 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
499 gfc_error ("Argument '%s' of statement function at %L must "
500 "be scalar", sym
->name
, &sym
->declared_at
);
504 if (sym
->ts
.type
== BT_CHARACTER
)
506 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
507 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
509 gfc_error ("Character-valued argument '%s' of statement "
510 "function at %L must have constant length",
511 sym
->name
, &sym
->declared_at
);
521 /* Work function called when searching for symbols that have argument lists
522 associated with them. */
525 find_arglists (gfc_symbol
*sym
)
527 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
528 || sym
->attr
.flavor
== FL_DERIVED
)
531 resolve_formal_arglist (sym
);
535 /* Given a namespace, resolve all formal argument lists within the namespace.
539 resolve_formal_arglists (gfc_namespace
*ns
)
544 gfc_traverse_ns (ns
, find_arglists
);
549 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
553 /* If this namespace is not a function or an entry master function,
555 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
556 || sym
->attr
.entry_master
)
559 /* Try to find out of what the return type is. */
560 if (sym
->result
->ts
.type
== BT_UNKNOWN
&& sym
->result
->ts
.interface
== NULL
)
562 t
= gfc_set_default_type (sym
->result
, 0, ns
);
564 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
566 if (sym
->result
== sym
)
567 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
568 sym
->name
, &sym
->declared_at
);
569 else if (!sym
->result
->attr
.proc_pointer
)
570 gfc_error ("Result '%s' of contained function '%s' at %L has "
571 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
572 &sym
->result
->declared_at
);
573 sym
->result
->attr
.untyped
= 1;
577 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
578 type, lists the only ways a character length value of * can be used:
579 dummy arguments of procedures, named constants, and function results
580 in external functions. Internal function results and results of module
581 procedures are not on this list, ergo, not permitted. */
583 if (sym
->result
->ts
.type
== BT_CHARACTER
)
585 gfc_charlen
*cl
= sym
->result
->ts
.u
.cl
;
586 if ((!cl
|| !cl
->length
) && !sym
->result
->ts
.deferred
)
588 /* See if this is a module-procedure and adapt error message
591 gcc_assert (ns
->parent
&& ns
->parent
->proc_name
);
592 module_proc
= (ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
);
594 gfc_error ("Character-valued %s '%s' at %L must not be"
596 module_proc
? _("module procedure")
597 : _("internal function"),
598 sym
->name
, &sym
->declared_at
);
604 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
605 introduce duplicates. */
608 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
610 gfc_formal_arglist
*f
, *new_arglist
;
613 for (; new_args
!= NULL
; new_args
= new_args
->next
)
615 new_sym
= new_args
->sym
;
616 /* See if this arg is already in the formal argument list. */
617 for (f
= proc
->formal
; f
; f
= f
->next
)
619 if (new_sym
== f
->sym
)
626 /* Add a new argument. Argument order is not important. */
627 new_arglist
= gfc_get_formal_arglist ();
628 new_arglist
->sym
= new_sym
;
629 new_arglist
->next
= proc
->formal
;
630 proc
->formal
= new_arglist
;
635 /* Flag the arguments that are not present in all entries. */
638 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
640 gfc_formal_arglist
*f
, *head
;
643 for (f
= proc
->formal
; f
; f
= f
->next
)
648 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
650 if (new_args
->sym
== f
->sym
)
657 f
->sym
->attr
.not_always_present
= 1;
662 /* Resolve alternate entry points. If a symbol has multiple entry points we
663 create a new master symbol for the main routine, and turn the existing
664 symbol into an entry point. */
667 resolve_entries (gfc_namespace
*ns
)
669 gfc_namespace
*old_ns
;
673 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
674 static int master_count
= 0;
676 if (ns
->proc_name
== NULL
)
679 /* No need to do anything if this procedure doesn't have alternate entry
684 /* We may already have resolved alternate entry points. */
685 if (ns
->proc_name
->attr
.entry_master
)
688 /* If this isn't a procedure something has gone horribly wrong. */
689 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
691 /* Remember the current namespace. */
692 old_ns
= gfc_current_ns
;
696 /* Add the main entry point to the list of entry points. */
697 el
= gfc_get_entry_list ();
698 el
->sym
= ns
->proc_name
;
700 el
->next
= ns
->entries
;
702 ns
->proc_name
->attr
.entry
= 1;
704 /* If it is a module function, it needs to be in the right namespace
705 so that gfc_get_fake_result_decl can gather up the results. The
706 need for this arose in get_proc_name, where these beasts were
707 left in their own namespace, to keep prior references linked to
708 the entry declaration.*/
709 if (ns
->proc_name
->attr
.function
710 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
713 /* Do the same for entries where the master is not a module
714 procedure. These are retained in the module namespace because
715 of the module procedure declaration. */
716 for (el
= el
->next
; el
; el
= el
->next
)
717 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
718 && el
->sym
->attr
.mod_proc
)
722 /* Add an entry statement for it. */
729 /* Create a new symbol for the master function. */
730 /* Give the internal function a unique name (within this file).
731 Also include the function name so the user has some hope of figuring
732 out what is going on. */
733 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
734 master_count
++, ns
->proc_name
->name
);
735 gfc_get_ha_symbol (name
, &proc
);
736 gcc_assert (proc
!= NULL
);
738 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
739 if (ns
->proc_name
->attr
.subroutine
)
740 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
744 gfc_typespec
*ts
, *fts
;
745 gfc_array_spec
*as
, *fas
;
746 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
748 fas
= ns
->entries
->sym
->as
;
749 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
750 fts
= &ns
->entries
->sym
->result
->ts
;
751 if (fts
->type
== BT_UNKNOWN
)
752 fts
= gfc_get_default_type (ns
->entries
->sym
->result
->name
, NULL
);
753 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
755 ts
= &el
->sym
->result
->ts
;
757 as
= as
? as
: el
->sym
->result
->as
;
758 if (ts
->type
== BT_UNKNOWN
)
759 ts
= gfc_get_default_type (el
->sym
->result
->name
, NULL
);
761 if (! gfc_compare_types (ts
, fts
)
762 || (el
->sym
->result
->attr
.dimension
763 != ns
->entries
->sym
->result
->attr
.dimension
)
764 || (el
->sym
->result
->attr
.pointer
765 != ns
->entries
->sym
->result
->attr
.pointer
))
767 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
768 && gfc_compare_array_spec (as
, fas
) == 0)
769 gfc_error ("Function %s at %L has entries with mismatched "
770 "array specifications", ns
->entries
->sym
->name
,
771 &ns
->entries
->sym
->declared_at
);
772 /* The characteristics need to match and thus both need to have
773 the same string length, i.e. both len=*, or both len=4.
774 Having both len=<variable> is also possible, but difficult to
775 check at compile time. */
776 else if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& fts
->u
.cl
777 && (((ts
->u
.cl
->length
&& !fts
->u
.cl
->length
)
778 ||(!ts
->u
.cl
->length
&& fts
->u
.cl
->length
))
780 && ts
->u
.cl
->length
->expr_type
781 != fts
->u
.cl
->length
->expr_type
)
783 && ts
->u
.cl
->length
->expr_type
== EXPR_CONSTANT
784 && mpz_cmp (ts
->u
.cl
->length
->value
.integer
,
785 fts
->u
.cl
->length
->value
.integer
) != 0)))
786 gfc_notify_std (GFC_STD_GNU
, "Function %s at %L with "
787 "entries returning variables of different "
788 "string lengths", ns
->entries
->sym
->name
,
789 &ns
->entries
->sym
->declared_at
);
794 sym
= ns
->entries
->sym
->result
;
795 /* All result types the same. */
797 if (sym
->attr
.dimension
)
798 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
799 if (sym
->attr
.pointer
)
800 gfc_add_pointer (&proc
->attr
, NULL
);
804 /* Otherwise the result will be passed through a union by
806 proc
->attr
.mixed_entry_master
= 1;
807 for (el
= ns
->entries
; el
; el
= el
->next
)
809 sym
= el
->sym
->result
;
810 if (sym
->attr
.dimension
)
812 if (el
== ns
->entries
)
813 gfc_error ("FUNCTION result %s can't be an array in "
814 "FUNCTION %s at %L", sym
->name
,
815 ns
->entries
->sym
->name
, &sym
->declared_at
);
817 gfc_error ("ENTRY result %s can't be an array in "
818 "FUNCTION %s at %L", sym
->name
,
819 ns
->entries
->sym
->name
, &sym
->declared_at
);
821 else if (sym
->attr
.pointer
)
823 if (el
== ns
->entries
)
824 gfc_error ("FUNCTION result %s can't be a POINTER in "
825 "FUNCTION %s at %L", sym
->name
,
826 ns
->entries
->sym
->name
, &sym
->declared_at
);
828 gfc_error ("ENTRY result %s can't be a POINTER in "
829 "FUNCTION %s at %L", sym
->name
,
830 ns
->entries
->sym
->name
, &sym
->declared_at
);
835 if (ts
->type
== BT_UNKNOWN
)
836 ts
= gfc_get_default_type (sym
->name
, NULL
);
840 if (ts
->kind
== gfc_default_integer_kind
)
844 if (ts
->kind
== gfc_default_real_kind
845 || ts
->kind
== gfc_default_double_kind
)
849 if (ts
->kind
== gfc_default_complex_kind
)
853 if (ts
->kind
== gfc_default_logical_kind
)
857 /* We will issue error elsewhere. */
865 if (el
== ns
->entries
)
866 gfc_error ("FUNCTION result %s can't be of type %s "
867 "in FUNCTION %s at %L", sym
->name
,
868 gfc_typename (ts
), ns
->entries
->sym
->name
,
871 gfc_error ("ENTRY result %s can't be of type %s "
872 "in FUNCTION %s at %L", sym
->name
,
873 gfc_typename (ts
), ns
->entries
->sym
->name
,
880 proc
->attr
.access
= ACCESS_PRIVATE
;
881 proc
->attr
.entry_master
= 1;
883 /* Merge all the entry point arguments. */
884 for (el
= ns
->entries
; el
; el
= el
->next
)
885 merge_argument_lists (proc
, el
->sym
->formal
);
887 /* Check the master formal arguments for any that are not
888 present in all entry points. */
889 for (el
= ns
->entries
; el
; el
= el
->next
)
890 check_argument_lists (proc
, el
->sym
->formal
);
892 /* Use the master function for the function body. */
893 ns
->proc_name
= proc
;
895 /* Finalize the new symbols. */
896 gfc_commit_symbols ();
898 /* Restore the original namespace. */
899 gfc_current_ns
= old_ns
;
903 /* Resolve common variables. */
905 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
907 gfc_symbol
*csym
= sym
;
909 for (; csym
; csym
= csym
->common_next
)
911 if (csym
->value
|| csym
->attr
.data
)
913 if (!csym
->ns
->is_block_data
)
914 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
915 "but only in BLOCK DATA initialization is "
916 "allowed", csym
->name
, &csym
->declared_at
);
917 else if (!named_common
)
918 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
919 "in a blank COMMON but initialization is only "
920 "allowed in named common blocks", csym
->name
,
924 if (csym
->ts
.type
!= BT_DERIVED
)
927 if (!(csym
->ts
.u
.derived
->attr
.sequence
928 || csym
->ts
.u
.derived
->attr
.is_bind_c
))
929 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
930 "has neither the SEQUENCE nor the BIND(C) "
931 "attribute", csym
->name
, &csym
->declared_at
);
932 if (csym
->ts
.u
.derived
->attr
.alloc_comp
)
933 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
934 "has an ultimate component that is "
935 "allocatable", csym
->name
, &csym
->declared_at
);
936 if (gfc_has_default_initializer (csym
->ts
.u
.derived
))
937 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
938 "may not have default initializer", csym
->name
,
941 if (csym
->attr
.flavor
== FL_UNKNOWN
&& !csym
->attr
.proc_pointer
)
942 gfc_add_flavor (&csym
->attr
, FL_VARIABLE
, csym
->name
, &csym
->declared_at
);
946 /* Resolve common blocks. */
948 resolve_common_blocks (gfc_symtree
*common_root
)
952 if (common_root
== NULL
)
955 if (common_root
->left
)
956 resolve_common_blocks (common_root
->left
);
957 if (common_root
->right
)
958 resolve_common_blocks (common_root
->right
);
960 resolve_common_vars (common_root
->n
.common
->head
, true);
962 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
966 if (sym
->attr
.flavor
== FL_PARAMETER
)
967 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
968 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
970 if (sym
->attr
.external
)
971 gfc_error ("COMMON block '%s' at %L can not have the EXTERNAL attribute",
972 sym
->name
, &common_root
->n
.common
->where
);
974 if (sym
->attr
.intrinsic
)
975 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
976 sym
->name
, &common_root
->n
.common
->where
);
977 else if (sym
->attr
.result
978 || gfc_is_function_return_value (sym
, gfc_current_ns
))
979 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
980 "that is also a function result", sym
->name
,
981 &common_root
->n
.common
->where
);
982 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
983 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
984 gfc_notify_std (GFC_STD_F2003
, "COMMON block '%s' at %L "
985 "that is also a global procedure", sym
->name
,
986 &common_root
->n
.common
->where
);
990 /* Resolve contained function types. Because contained functions can call one
991 another, they have to be worked out before any of the contained procedures
994 The good news is that if a function doesn't already have a type, the only
995 way it can get one is through an IMPLICIT type or a RESULT variable, because
996 by definition contained functions are contained namespace they're contained
997 in, not in a sibling or parent namespace. */
1000 resolve_contained_functions (gfc_namespace
*ns
)
1002 gfc_namespace
*child
;
1005 resolve_formal_arglists (ns
);
1007 for (child
= ns
->contained
; child
; child
= child
->sibling
)
1009 /* Resolve alternate entry points first. */
1010 resolve_entries (child
);
1012 /* Then check function return types. */
1013 resolve_contained_fntype (child
->proc_name
, child
);
1014 for (el
= child
->entries
; el
; el
= el
->next
)
1015 resolve_contained_fntype (el
->sym
, child
);
1020 static gfc_try
resolve_fl_derived0 (gfc_symbol
*sym
);
1023 /* Resolve all of the elements of a structure constructor and make sure that
1024 the types are correct. The 'init' flag indicates that the given
1025 constructor is an initializer. */
1028 resolve_structure_cons (gfc_expr
*expr
, int init
)
1030 gfc_constructor
*cons
;
1031 gfc_component
*comp
;
1037 if (expr
->ts
.type
== BT_DERIVED
)
1038 resolve_fl_derived0 (expr
->ts
.u
.derived
);
1040 cons
= gfc_constructor_first (expr
->value
.constructor
);
1042 /* See if the user is trying to invoke a structure constructor for one of
1043 the iso_c_binding derived types. */
1044 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1045 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1046 && (cons
->expr
== NULL
|| cons
->expr
->expr_type
!= EXPR_NULL
))
1048 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
1049 expr
->ts
.u
.derived
->name
, &(expr
->where
));
1053 /* Return if structure constructor is c_null_(fun)prt. */
1054 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
1055 && expr
->ts
.u
.derived
->ts
.is_iso_c
&& cons
1056 && cons
->expr
&& cons
->expr
->expr_type
== EXPR_NULL
)
1059 /* A constructor may have references if it is the result of substituting a
1060 parameter variable. In this case we just pull out the component we
1063 comp
= expr
->ref
->u
.c
.sym
->components
;
1065 comp
= expr
->ts
.u
.derived
->components
;
1067 for (; comp
&& cons
; comp
= comp
->next
, cons
= gfc_constructor_next (cons
))
1074 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
1080 rank
= comp
->as
? comp
->as
->rank
: 0;
1081 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
1082 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
1084 gfc_error ("The rank of the element in the structure "
1085 "constructor at %L does not match that of the "
1086 "component (%d/%d)", &cons
->expr
->where
,
1087 cons
->expr
->rank
, rank
);
1091 /* If we don't have the right type, try to convert it. */
1093 if (!comp
->attr
.proc_pointer
&&
1094 !gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
1097 if (strcmp (comp
->name
, "_extends") == 0)
1099 /* Can afford to be brutal with the _extends initializer.
1100 The derived type can get lost because it is PRIVATE
1101 but it is not usage constrained by the standard. */
1102 cons
->expr
->ts
= comp
->ts
;
1105 else if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
1106 gfc_error ("The element in the structure constructor at %L, "
1107 "for pointer component '%s', is %s but should be %s",
1108 &cons
->expr
->where
, comp
->name
,
1109 gfc_basic_typename (cons
->expr
->ts
.type
),
1110 gfc_basic_typename (comp
->ts
.type
));
1112 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
1115 /* For strings, the length of the constructor should be the same as
1116 the one of the structure, ensure this if the lengths are known at
1117 compile time and when we are dealing with PARAMETER or structure
1119 if (cons
->expr
->ts
.type
== BT_CHARACTER
&& comp
->ts
.u
.cl
1120 && comp
->ts
.u
.cl
->length
1121 && comp
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1122 && cons
->expr
->ts
.u
.cl
&& cons
->expr
->ts
.u
.cl
->length
1123 && cons
->expr
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
1124 && cons
->expr
->rank
!= 0
1125 && mpz_cmp (cons
->expr
->ts
.u
.cl
->length
->value
.integer
,
1126 comp
->ts
.u
.cl
->length
->value
.integer
) != 0)
1128 if (cons
->expr
->expr_type
== EXPR_VARIABLE
1129 && cons
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
1131 /* Wrap the parameter in an array constructor (EXPR_ARRAY)
1132 to make use of the gfc_resolve_character_array_constructor
1133 machinery. The expression is later simplified away to
1134 an array of string literals. */
1135 gfc_expr
*para
= cons
->expr
;
1136 cons
->expr
= gfc_get_expr ();
1137 cons
->expr
->ts
= para
->ts
;
1138 cons
->expr
->where
= para
->where
;
1139 cons
->expr
->expr_type
= EXPR_ARRAY
;
1140 cons
->expr
->rank
= para
->rank
;
1141 cons
->expr
->shape
= gfc_copy_shape (para
->shape
, para
->rank
);
1142 gfc_constructor_append_expr (&cons
->expr
->value
.constructor
,
1143 para
, &cons
->expr
->where
);
1145 if (cons
->expr
->expr_type
== EXPR_ARRAY
)
1148 p
= gfc_constructor_first (cons
->expr
->value
.constructor
);
1149 if (cons
->expr
->ts
.u
.cl
!= p
->expr
->ts
.u
.cl
)
1151 gfc_charlen
*cl
, *cl2
;
1154 for (cl
= gfc_current_ns
->cl_list
; cl
; cl
= cl
->next
)
1156 if (cl
== cons
->expr
->ts
.u
.cl
)
1164 cl2
->next
= cl
->next
;
1166 gfc_free_expr (cl
->length
);
1170 cons
->expr
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1171 cons
->expr
->ts
.u
.cl
->length_from_typespec
= true;
1172 cons
->expr
->ts
.u
.cl
->length
= gfc_copy_expr (comp
->ts
.u
.cl
->length
);
1173 gfc_resolve_character_array_constructor (cons
->expr
);
1177 if (cons
->expr
->expr_type
== EXPR_NULL
1178 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
1179 || comp
->attr
.proc_pointer
1180 || (comp
->ts
.type
== BT_CLASS
1181 && (CLASS_DATA (comp
)->attr
.class_pointer
1182 || CLASS_DATA (comp
)->attr
.allocatable
))))
1185 gfc_error ("The NULL in the structure constructor at %L is "
1186 "being applied to component '%s', which is neither "
1187 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
1191 if (comp
->attr
.proc_pointer
&& comp
->ts
.interface
)
1193 /* Check procedure pointer interface. */
1194 gfc_symbol
*s2
= NULL
;
1199 c2
= gfc_get_proc_ptr_comp (cons
->expr
);
1202 s2
= c2
->ts
.interface
;
1205 else if (cons
->expr
->expr_type
== EXPR_FUNCTION
)
1207 s2
= cons
->expr
->symtree
->n
.sym
->result
;
1208 name
= cons
->expr
->symtree
->n
.sym
->result
->name
;
1210 else if (cons
->expr
->expr_type
!= EXPR_NULL
)
1212 s2
= cons
->expr
->symtree
->n
.sym
;
1213 name
= cons
->expr
->symtree
->n
.sym
->name
;
1216 if (s2
&& !gfc_compare_interfaces (comp
->ts
.interface
, s2
, name
, 0, 1,
1217 err
, sizeof (err
), NULL
, NULL
))
1219 gfc_error ("Interface mismatch for procedure-pointer component "
1220 "'%s' in structure constructor at %L: %s",
1221 comp
->name
, &cons
->expr
->where
, err
);
1226 if (!comp
->attr
.pointer
|| comp
->attr
.proc_pointer
1227 || cons
->expr
->expr_type
== EXPR_NULL
)
1230 a
= gfc_expr_attr (cons
->expr
);
1232 if (!a
.pointer
&& !a
.target
)
1235 gfc_error ("The element in the structure constructor at %L, "
1236 "for pointer component '%s' should be a POINTER or "
1237 "a TARGET", &cons
->expr
->where
, comp
->name
);
1242 /* F08:C461. Additional checks for pointer initialization. */
1246 gfc_error ("Pointer initialization target at %L "
1247 "must not be ALLOCATABLE ", &cons
->expr
->where
);
1252 gfc_error ("Pointer initialization target at %L "
1253 "must have the SAVE attribute", &cons
->expr
->where
);
1257 /* F2003, C1272 (3). */
1258 if (gfc_pure (NULL
) && cons
->expr
->expr_type
== EXPR_VARIABLE
1259 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1260 || gfc_is_coindexed (cons
->expr
)))
1263 gfc_error ("Invalid expression in the structure constructor for "
1264 "pointer component '%s' at %L in PURE procedure",
1265 comp
->name
, &cons
->expr
->where
);
1268 if (gfc_implicit_pure (NULL
)
1269 && cons
->expr
->expr_type
== EXPR_VARIABLE
1270 && (gfc_impure_variable (cons
->expr
->symtree
->n
.sym
)
1271 || gfc_is_coindexed (cons
->expr
)))
1272 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
1280 /****************** Expression name resolution ******************/
1282 /* Returns 0 if a symbol was not declared with a type or
1283 attribute declaration statement, nonzero otherwise. */
1286 was_declared (gfc_symbol
*sym
)
1292 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
1295 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
1296 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
1297 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
1298 || a
.asynchronous
|| a
.codimension
)
1305 /* Determine if a symbol is generic or not. */
1308 generic_sym (gfc_symbol
*sym
)
1312 if (sym
->attr
.generic
||
1313 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
1316 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1319 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1326 return generic_sym (s
);
1333 /* Determine if a symbol is specific or not. */
1336 specific_sym (gfc_symbol
*sym
)
1340 if (sym
->attr
.if_source
== IFSRC_IFBODY
1341 || sym
->attr
.proc
== PROC_MODULE
1342 || sym
->attr
.proc
== PROC_INTERNAL
1343 || sym
->attr
.proc
== PROC_ST_FUNCTION
1344 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
1345 || sym
->attr
.external
)
1348 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1351 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
1353 return (s
== NULL
) ? 0 : specific_sym (s
);
1357 /* Figure out if the procedure is specific, generic or unknown. */
1360 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
1364 procedure_kind (gfc_symbol
*sym
)
1366 if (generic_sym (sym
))
1367 return PTYPE_GENERIC
;
1369 if (specific_sym (sym
))
1370 return PTYPE_SPECIFIC
;
1372 return PTYPE_UNKNOWN
;
1375 /* Check references to assumed size arrays. The flag need_full_assumed_size
1376 is nonzero when matching actual arguments. */
1378 static int need_full_assumed_size
= 0;
1381 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
1383 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
1386 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
1387 What should it be? */
1388 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1389 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1390 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1392 gfc_error ("The upper bound in the last dimension must "
1393 "appear in the reference to the assumed size "
1394 "array '%s' at %L", sym
->name
, &e
->where
);
1401 /* Look for bad assumed size array references in argument expressions
1402 of elemental and array valued intrinsic procedures. Since this is
1403 called from procedure resolution functions, it only recurses at
1407 resolve_assumed_size_actual (gfc_expr
*e
)
1412 switch (e
->expr_type
)
1415 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1420 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1421 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1432 /* Check a generic procedure, passed as an actual argument, to see if
1433 there is a matching specific name. If none, it is an error, and if
1434 more than one, the reference is ambiguous. */
1436 count_specific_procs (gfc_expr
*e
)
1443 sym
= e
->symtree
->n
.sym
;
1445 for (p
= sym
->generic
; p
; p
= p
->next
)
1446 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1448 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1454 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1458 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1459 "argument at %L", sym
->name
, &e
->where
);
1465 /* See if a call to sym could possibly be a not allowed RECURSION because of
1466 a missing RECURSIVE declaration. This means that either sym is the current
1467 context itself, or sym is the parent of a contained procedure calling its
1468 non-RECURSIVE containing procedure.
1469 This also works if sym is an ENTRY. */
1472 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1474 gfc_symbol
* proc_sym
;
1475 gfc_symbol
* context_proc
;
1476 gfc_namespace
* real_context
;
1478 if (sym
->attr
.flavor
== FL_PROGRAM
1479 || sym
->attr
.flavor
== FL_DERIVED
)
1482 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1484 /* If we've got an ENTRY, find real procedure. */
1485 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1486 proc_sym
= sym
->ns
->entries
->sym
;
1490 /* If sym is RECURSIVE, all is well of course. */
1491 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1494 /* Find the context procedure's "real" symbol if it has entries.
1495 We look for a procedure symbol, so recurse on the parents if we don't
1496 find one (like in case of a BLOCK construct). */
1497 for (real_context
= context
; ; real_context
= real_context
->parent
)
1499 /* We should find something, eventually! */
1500 gcc_assert (real_context
);
1502 context_proc
= (real_context
->entries
? real_context
->entries
->sym
1503 : real_context
->proc_name
);
1505 /* In some special cases, there may not be a proc_name, like for this
1507 real(bad_kind()) function foo () ...
1508 when checking the call to bad_kind ().
1509 In these cases, we simply return here and assume that the
1514 if (context_proc
->attr
.flavor
!= FL_LABEL
)
1518 /* A call from sym's body to itself is recursion, of course. */
1519 if (context_proc
== proc_sym
)
1522 /* The same is true if context is a contained procedure and sym the
1524 if (context_proc
->attr
.contained
)
1526 gfc_symbol
* parent_proc
;
1528 gcc_assert (context
->parent
);
1529 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1530 : context
->parent
->proc_name
);
1532 if (parent_proc
== proc_sym
)
1540 /* Resolve an intrinsic procedure: Set its function/subroutine attribute,
1541 its typespec and formal argument list. */
1544 gfc_resolve_intrinsic (gfc_symbol
*sym
, locus
*loc
)
1546 gfc_intrinsic_sym
* isym
= NULL
;
1552 /* Already resolved. */
1553 if (sym
->from_intmod
&& sym
->ts
.type
!= BT_UNKNOWN
)
1556 /* We already know this one is an intrinsic, so we don't call
1557 gfc_is_intrinsic for full checking but rather use gfc_find_function and
1558 gfc_find_subroutine directly to check whether it is a function or
1561 if (sym
->intmod_sym_id
)
1562 isym
= gfc_intrinsic_function_by_id ((gfc_isym_id
) sym
->intmod_sym_id
);
1563 else if (!sym
->attr
.subroutine
)
1564 isym
= gfc_find_function (sym
->name
);
1568 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
1569 && !sym
->attr
.implicit_type
)
1570 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
1571 " ignored", sym
->name
, &sym
->declared_at
);
1573 if (!sym
->attr
.function
&&
1574 gfc_add_function (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1579 else if ((isym
= gfc_find_subroutine (sym
->name
)))
1581 if (sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.implicit_type
)
1583 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
1584 " specifier", sym
->name
, &sym
->declared_at
);
1588 if (!sym
->attr
.subroutine
&&
1589 gfc_add_subroutine (&sym
->attr
, sym
->name
, loc
) == FAILURE
)
1594 gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym
->name
,
1599 gfc_copy_formal_args_intr (sym
, isym
);
1601 /* Check it is actually available in the standard settings. */
1602 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
1605 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
1606 " available in the current standard settings but %s. Use"
1607 " an appropriate -std=* option or enable -fall-intrinsics"
1608 " in order to use it.",
1609 sym
->name
, &sym
->declared_at
, symstd
);
1617 /* Resolve a procedure expression, like passing it to a called procedure or as
1618 RHS for a procedure pointer assignment. */
1621 resolve_procedure_expression (gfc_expr
* expr
)
1625 if (expr
->expr_type
!= EXPR_VARIABLE
)
1627 gcc_assert (expr
->symtree
);
1629 sym
= expr
->symtree
->n
.sym
;
1631 if (sym
->attr
.intrinsic
)
1632 gfc_resolve_intrinsic (sym
, &expr
->where
);
1634 if (sym
->attr
.flavor
!= FL_PROCEDURE
1635 || (sym
->attr
.function
&& sym
->result
== sym
))
1638 /* A non-RECURSIVE procedure that is used as procedure expression within its
1639 own body is in danger of being called recursively. */
1640 if (is_illegal_recursion (sym
, gfc_current_ns
))
1641 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1642 " itself recursively. Declare it RECURSIVE or use"
1643 " -frecursive", sym
->name
, &expr
->where
);
1649 /* Resolve an actual argument list. Most of the time, this is just
1650 resolving the expressions in the list.
1651 The exception is that we sometimes have to decide whether arguments
1652 that look like procedure arguments are really simple variable
1656 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1657 bool no_formal_args
)
1660 gfc_symtree
*parent_st
;
1662 int save_need_full_assumed_size
;
1663 gfc_try return_value
= FAILURE
;
1664 bool actual_arg_sav
= actual_arg
, first_actual_arg_sav
= first_actual_arg
;
1667 first_actual_arg
= true;
1669 for (; arg
; arg
= arg
->next
)
1674 /* Check the label is a valid branching target. */
1677 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1679 gfc_error ("Label %d referenced at %L is never defined",
1680 arg
->label
->value
, &arg
->label
->where
);
1684 first_actual_arg
= false;
1688 if (e
->expr_type
== EXPR_VARIABLE
1689 && e
->symtree
->n
.sym
->attr
.generic
1691 && count_specific_procs (e
) != 1)
1694 if (e
->ts
.type
!= BT_PROCEDURE
)
1696 save_need_full_assumed_size
= need_full_assumed_size
;
1697 if (e
->expr_type
!= EXPR_VARIABLE
)
1698 need_full_assumed_size
= 0;
1699 if (gfc_resolve_expr (e
) != SUCCESS
)
1701 need_full_assumed_size
= save_need_full_assumed_size
;
1705 /* See if the expression node should really be a variable reference. */
1707 sym
= e
->symtree
->n
.sym
;
1709 if (sym
->attr
.flavor
== FL_PROCEDURE
1710 || sym
->attr
.intrinsic
1711 || sym
->attr
.external
)
1715 /* If a procedure is not already determined to be something else
1716 check if it is intrinsic. */
1717 if (gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1718 sym
->attr
.intrinsic
= 1;
1720 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1722 gfc_error ("Statement function '%s' at %L is not allowed as an "
1723 "actual argument", sym
->name
, &e
->where
);
1726 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1727 sym
->attr
.subroutine
);
1728 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1730 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1731 "actual argument", sym
->name
, &e
->where
);
1734 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1735 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1737 if (gfc_notify_std (GFC_STD_F2008
,
1738 "Internal procedure '%s' is"
1739 " used as actual argument at %L",
1740 sym
->name
, &e
->where
) == FAILURE
)
1744 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1746 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1747 "allowed as an actual argument at %L", sym
->name
,
1751 /* Check if a generic interface has a specific procedure
1752 with the same name before emitting an error. */
1753 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1756 /* Just in case a specific was found for the expression. */
1757 sym
= e
->symtree
->n
.sym
;
1759 /* If the symbol is the function that names the current (or
1760 parent) scope, then we really have a variable reference. */
1762 if (gfc_is_function_return_value (sym
, sym
->ns
))
1765 /* If all else fails, see if we have a specific intrinsic. */
1766 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1768 gfc_intrinsic_sym
*isym
;
1770 isym
= gfc_find_function (sym
->name
);
1771 if (isym
== NULL
|| !isym
->specific
)
1773 gfc_error ("Unable to find a specific INTRINSIC procedure "
1774 "for the reference '%s' at %L", sym
->name
,
1779 sym
->attr
.intrinsic
= 1;
1780 sym
->attr
.function
= 1;
1783 if (gfc_resolve_expr (e
) == FAILURE
)
1788 /* See if the name is a module procedure in a parent unit. */
1790 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1793 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1795 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1799 if (parent_st
== NULL
)
1802 sym
= parent_st
->n
.sym
;
1803 e
->symtree
= parent_st
; /* Point to the right thing. */
1805 if (sym
->attr
.flavor
== FL_PROCEDURE
1806 || sym
->attr
.intrinsic
1807 || sym
->attr
.external
)
1809 if (gfc_resolve_expr (e
) == FAILURE
)
1815 e
->expr_type
= EXPR_VARIABLE
;
1817 if ((sym
->as
!= NULL
&& sym
->ts
.type
!= BT_CLASS
)
1818 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
1819 && CLASS_DATA (sym
)->as
))
1821 e
->rank
= sym
->ts
.type
== BT_CLASS
1822 ? CLASS_DATA (sym
)->as
->rank
: sym
->as
->rank
;
1823 e
->ref
= gfc_get_ref ();
1824 e
->ref
->type
= REF_ARRAY
;
1825 e
->ref
->u
.ar
.type
= AR_FULL
;
1826 e
->ref
->u
.ar
.as
= sym
->ts
.type
== BT_CLASS
1827 ? CLASS_DATA (sym
)->as
: sym
->as
;
1830 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1831 primary.c (match_actual_arg). If above code determines that it
1832 is a variable instead, it needs to be resolved as it was not
1833 done at the beginning of this function. */
1834 save_need_full_assumed_size
= need_full_assumed_size
;
1835 if (e
->expr_type
!= EXPR_VARIABLE
)
1836 need_full_assumed_size
= 0;
1837 if (gfc_resolve_expr (e
) != SUCCESS
)
1839 need_full_assumed_size
= save_need_full_assumed_size
;
1842 /* Check argument list functions %VAL, %LOC and %REF. There is
1843 nothing to do for %REF. */
1844 if (arg
->name
&& arg
->name
[0] == '%')
1846 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1848 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1850 gfc_error ("By-value argument at %L is not of numeric "
1857 gfc_error ("By-value argument at %L cannot be an array or "
1858 "an array section", &e
->where
);
1862 /* Intrinsics are still PROC_UNKNOWN here. However,
1863 since same file external procedures are not resolvable
1864 in gfortran, it is a good deal easier to leave them to
1866 if (ptype
!= PROC_UNKNOWN
1867 && ptype
!= PROC_DUMMY
1868 && ptype
!= PROC_EXTERNAL
1869 && ptype
!= PROC_MODULE
)
1871 gfc_error ("By-value argument at %L is not allowed "
1872 "in this context", &e
->where
);
1877 /* Statement functions have already been excluded above. */
1878 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1879 && e
->ts
.type
== BT_PROCEDURE
)
1881 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1883 gfc_error ("Passing internal procedure at %L by location "
1884 "not allowed", &e
->where
);
1890 /* Fortran 2008, C1237. */
1891 if (e
->expr_type
== EXPR_VARIABLE
&& gfc_is_coindexed (e
)
1892 && gfc_has_ultimate_pointer (e
))
1894 gfc_error ("Coindexed actual argument at %L with ultimate pointer "
1895 "component", &e
->where
);
1899 first_actual_arg
= false;
1902 return_value
= SUCCESS
;
1905 actual_arg
= actual_arg_sav
;
1906 first_actual_arg
= first_actual_arg_sav
;
1908 return return_value
;
1912 /* Do the checks of the actual argument list that are specific to elemental
1913 procedures. If called with c == NULL, we have a function, otherwise if
1914 expr == NULL, we have a subroutine. */
1917 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1919 gfc_actual_arglist
*arg0
;
1920 gfc_actual_arglist
*arg
;
1921 gfc_symbol
*esym
= NULL
;
1922 gfc_intrinsic_sym
*isym
= NULL
;
1924 gfc_intrinsic_arg
*iformal
= NULL
;
1925 gfc_formal_arglist
*eformal
= NULL
;
1926 bool formal_optional
= false;
1927 bool set_by_optional
= false;
1931 /* Is this an elemental procedure? */
1932 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1934 if (expr
->value
.function
.esym
!= NULL
1935 && expr
->value
.function
.esym
->attr
.elemental
)
1937 arg0
= expr
->value
.function
.actual
;
1938 esym
= expr
->value
.function
.esym
;
1940 else if (expr
->value
.function
.isym
!= NULL
1941 && expr
->value
.function
.isym
->elemental
)
1943 arg0
= expr
->value
.function
.actual
;
1944 isym
= expr
->value
.function
.isym
;
1949 else if (c
&& c
->ext
.actual
!= NULL
)
1951 arg0
= c
->ext
.actual
;
1953 if (c
->resolved_sym
)
1954 esym
= c
->resolved_sym
;
1956 esym
= c
->symtree
->n
.sym
;
1959 if (!esym
->attr
.elemental
)
1965 /* The rank of an elemental is the rank of its array argument(s). */
1966 for (arg
= arg0
; arg
; arg
= arg
->next
)
1968 if (arg
->expr
!= NULL
&& arg
->expr
->rank
!= 0)
1970 rank
= arg
->expr
->rank
;
1971 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1972 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1973 set_by_optional
= true;
1975 /* Function specific; set the result rank and shape. */
1979 if (!expr
->shape
&& arg
->expr
->shape
)
1981 expr
->shape
= gfc_get_shape (rank
);
1982 for (i
= 0; i
< rank
; i
++)
1983 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1990 /* If it is an array, it shall not be supplied as an actual argument
1991 to an elemental procedure unless an array of the same rank is supplied
1992 as an actual argument corresponding to a nonoptional dummy argument of
1993 that elemental procedure(12.4.1.5). */
1994 formal_optional
= false;
1996 iformal
= isym
->formal
;
1998 eformal
= esym
->formal
;
2000 for (arg
= arg0
; arg
; arg
= arg
->next
)
2004 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
2005 formal_optional
= true;
2006 eformal
= eformal
->next
;
2008 else if (isym
&& iformal
)
2010 if (iformal
->optional
)
2011 formal_optional
= true;
2012 iformal
= iformal
->next
;
2015 formal_optional
= true;
2017 if (pedantic
&& arg
->expr
!= NULL
2018 && arg
->expr
->expr_type
== EXPR_VARIABLE
2019 && arg
->expr
->symtree
->n
.sym
->attr
.optional
2022 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
2023 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
2025 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
2026 "MISSING, it cannot be the actual argument of an "
2027 "ELEMENTAL procedure unless there is a non-optional "
2028 "argument with the same rank (12.4.1.5)",
2029 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
2033 for (arg
= arg0
; arg
; arg
= arg
->next
)
2035 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2038 /* Being elemental, the last upper bound of an assumed size array
2039 argument must be present. */
2040 if (resolve_assumed_size_actual (arg
->expr
))
2043 /* Elemental procedure's array actual arguments must conform. */
2046 if (gfc_check_conformance (arg
->expr
, e
,
2047 "elemental procedure") == FAILURE
)
2054 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
2055 is an array, the intent inout/out variable needs to be also an array. */
2056 if (rank
> 0 && esym
&& expr
== NULL
)
2057 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
2058 arg
= arg
->next
, eformal
= eformal
->next
)
2059 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
2060 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
2061 && arg
->expr
&& arg
->expr
->rank
== 0)
2063 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
2064 "ELEMENTAL subroutine '%s' is a scalar, but another "
2065 "actual argument is an array", &arg
->expr
->where
,
2066 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
2067 : "INOUT", eformal
->sym
->name
, esym
->name
);
2074 /* This function does the checking of references to global procedures
2075 as defined in sections 18.1 and 14.1, respectively, of the Fortran
2076 77 and 95 standards. It checks for a gsymbol for the name, making
2077 one if it does not already exist. If it already exists, then the
2078 reference being resolved must correspond to the type of gsymbol.
2079 Otherwise, the new symbol is equipped with the attributes of the
2080 reference. The corresponding code that is called in creating
2081 global entities is parse.c.
2083 In addition, for all but -std=legacy, the gsymbols are used to
2084 check the interfaces of external procedures from the same file.
2085 The namespace of the gsymbol is resolved and then, once this is
2086 done the interface is checked. */
2090 not_in_recursive (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2092 if (!gsym_ns
->proc_name
->attr
.recursive
)
2095 if (sym
->ns
== gsym_ns
)
2098 if (sym
->ns
->parent
&& sym
->ns
->parent
== gsym_ns
)
2105 not_entry_self_reference (gfc_symbol
*sym
, gfc_namespace
*gsym_ns
)
2107 if (gsym_ns
->entries
)
2109 gfc_entry_list
*entry
= gsym_ns
->entries
;
2111 for (; entry
; entry
= entry
->next
)
2113 if (strcmp (sym
->name
, entry
->sym
->name
) == 0)
2115 if (strcmp (gsym_ns
->proc_name
->name
,
2116 sym
->ns
->proc_name
->name
) == 0)
2120 && strcmp (gsym_ns
->proc_name
->name
,
2121 sym
->ns
->parent
->proc_name
->name
) == 0)
2130 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
,
2131 gfc_actual_arglist
**actual
, int sub
)
2135 enum gfc_symbol_type type
;
2137 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2139 gsym
= gfc_get_gsymbol (sym
->name
);
2141 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
2142 gfc_global_used (gsym
, where
);
2144 if (gfc_option
.flag_whole_file
2145 && (sym
->attr
.if_source
== IFSRC_UNKNOWN
2146 || sym
->attr
.if_source
== IFSRC_IFBODY
)
2147 && gsym
->type
!= GSYM_UNKNOWN
2149 && gsym
->ns
->resolved
!= -1
2150 && gsym
->ns
->proc_name
2151 && not_in_recursive (sym
, gsym
->ns
)
2152 && not_entry_self_reference (sym
, gsym
->ns
))
2154 gfc_symbol
*def_sym
;
2156 /* Resolve the gsymbol namespace if needed. */
2157 if (!gsym
->ns
->resolved
)
2159 gfc_dt_list
*old_dt_list
;
2160 struct gfc_omp_saved_state old_omp_state
;
2162 /* Stash away derived types so that the backend_decls do not
2164 old_dt_list
= gfc_derived_types
;
2165 gfc_derived_types
= NULL
;
2166 /* And stash away openmp state. */
2167 gfc_omp_save_and_clear_state (&old_omp_state
);
2169 gfc_resolve (gsym
->ns
);
2171 /* Store the new derived types with the global namespace. */
2172 if (gfc_derived_types
)
2173 gsym
->ns
->derived_types
= gfc_derived_types
;
2175 /* Restore the derived types of this namespace. */
2176 gfc_derived_types
= old_dt_list
;
2177 /* And openmp state. */
2178 gfc_omp_restore_state (&old_omp_state
);
2181 /* Make sure that translation for the gsymbol occurs before
2182 the procedure currently being resolved. */
2183 ns
= gfc_global_ns_list
;
2184 for (; ns
&& ns
!= gsym
->ns
; ns
= ns
->sibling
)
2186 if (ns
->sibling
== gsym
->ns
)
2188 ns
->sibling
= gsym
->ns
->sibling
;
2189 gsym
->ns
->sibling
= gfc_global_ns_list
;
2190 gfc_global_ns_list
= gsym
->ns
;
2195 def_sym
= gsym
->ns
->proc_name
;
2196 if (def_sym
->attr
.entry_master
)
2198 gfc_entry_list
*entry
;
2199 for (entry
= gsym
->ns
->entries
; entry
; entry
= entry
->next
)
2200 if (strcmp (entry
->sym
->name
, sym
->name
) == 0)
2202 def_sym
= entry
->sym
;
2207 /* Differences in constant character lengths. */
2208 if (sym
->attr
.function
&& sym
->ts
.type
== BT_CHARACTER
)
2210 long int l1
= 0, l2
= 0;
2211 gfc_charlen
*cl1
= sym
->ts
.u
.cl
;
2212 gfc_charlen
*cl2
= def_sym
->ts
.u
.cl
;
2215 && cl1
->length
!= NULL
2216 && cl1
->length
->expr_type
== EXPR_CONSTANT
)
2217 l1
= mpz_get_si (cl1
->length
->value
.integer
);
2220 && cl2
->length
!= NULL
2221 && cl2
->length
->expr_type
== EXPR_CONSTANT
)
2222 l2
= mpz_get_si (cl2
->length
->value
.integer
);
2224 if (l1
&& l2
&& l1
!= l2
)
2225 gfc_error ("Character length mismatch in return type of "
2226 "function '%s' at %L (%ld/%ld)", sym
->name
,
2227 &sym
->declared_at
, l1
, l2
);
2230 /* Type mismatch of function return type and expected type. */
2231 if (sym
->attr
.function
2232 && !gfc_compare_types (&sym
->ts
, &def_sym
->ts
))
2233 gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
2234 sym
->name
, &sym
->declared_at
, gfc_typename (&sym
->ts
),
2235 gfc_typename (&def_sym
->ts
));
2237 if (def_sym
->formal
&& sym
->attr
.if_source
!= IFSRC_IFBODY
)
2239 gfc_formal_arglist
*arg
= def_sym
->formal
;
2240 for ( ; arg
; arg
= arg
->next
)
2243 /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a) */
2244 else if (arg
->sym
->attr
.allocatable
2245 || arg
->sym
->attr
.asynchronous
2246 || arg
->sym
->attr
.optional
2247 || arg
->sym
->attr
.pointer
2248 || arg
->sym
->attr
.target
2249 || arg
->sym
->attr
.value
2250 || arg
->sym
->attr
.volatile_
)
2252 gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
2253 "has an attribute that requires an explicit "
2254 "interface for this procedure", arg
->sym
->name
,
2255 sym
->name
, &sym
->declared_at
);
2258 /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b) */
2259 else if (arg
->sym
&& arg
->sym
->as
2260 && arg
->sym
->as
->type
== AS_ASSUMED_SHAPE
)
2262 gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
2263 "argument '%s' must have an explicit interface",
2264 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2267 /* TS 29113, 6.2. */
2268 else if (arg
->sym
&& arg
->sym
->as
2269 && arg
->sym
->as
->type
== AS_ASSUMED_RANK
)
2271 gfc_error ("Procedure '%s' at %L with assumed-rank dummy "
2272 "argument '%s' must have an explicit interface",
2273 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2276 /* F2008, 12.4.2.2 (2c) */
2277 else if (arg
->sym
->attr
.codimension
)
2279 gfc_error ("Procedure '%s' at %L with coarray dummy argument "
2280 "'%s' must have an explicit interface",
2281 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2284 /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d) */
2285 else if (false) /* TODO: is a parametrized derived type */
2287 gfc_error ("Procedure '%s' at %L with parametrized derived "
2288 "type argument '%s' must have an explicit "
2289 "interface", sym
->name
, &sym
->declared_at
,
2293 /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e) */
2294 else if (arg
->sym
->ts
.type
== BT_CLASS
)
2296 gfc_error ("Procedure '%s' at %L with polymorphic dummy "
2297 "argument '%s' must have an explicit interface",
2298 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2301 /* As assumed-type is unlimited polymorphic (cf. above).
2302 See also TS 29113, Note 6.1. */
2303 else if (arg
->sym
->ts
.type
== BT_ASSUMED
)
2305 gfc_error ("Procedure '%s' at %L with assumed-type dummy "
2306 "argument '%s' must have an explicit interface",
2307 sym
->name
, &sym
->declared_at
, arg
->sym
->name
);
2312 if (def_sym
->attr
.function
)
2314 /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
2315 if (def_sym
->as
&& def_sym
->as
->rank
2316 && (!sym
->as
|| sym
->as
->rank
!= def_sym
->as
->rank
))
2317 gfc_error ("The reference to function '%s' at %L either needs an "
2318 "explicit INTERFACE or the rank is incorrect", sym
->name
,
2321 /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
2322 if ((def_sym
->result
->attr
.pointer
2323 || def_sym
->result
->attr
.allocatable
)
2324 && (sym
->attr
.if_source
!= IFSRC_IFBODY
2325 || def_sym
->result
->attr
.pointer
2326 != sym
->result
->attr
.pointer
2327 || def_sym
->result
->attr
.allocatable
2328 != sym
->result
->attr
.allocatable
))
2329 gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
2330 "result must have an explicit interface", sym
->name
,
2333 /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c) */
2334 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->attr
.if_source
!= IFSRC_IFBODY
2335 && def_sym
->ts
.type
== BT_CHARACTER
&& def_sym
->ts
.u
.cl
->length
!= NULL
)
2337 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
2339 if (!sym
->attr
.entry_master
&& sym
->attr
.if_source
== IFSRC_UNKNOWN
2340 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
2342 gfc_error ("Nonconstant character-length function '%s' at %L "
2343 "must have an explicit interface", sym
->name
,
2349 /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
2350 if (def_sym
->attr
.elemental
&& !sym
->attr
.elemental
)
2352 gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
2353 "interface", sym
->name
, &sym
->declared_at
);
2356 /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
2357 if (def_sym
->attr
.is_bind_c
&& !sym
->attr
.is_bind_c
)
2359 gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
2360 "an explicit interface", sym
->name
, &sym
->declared_at
);
2363 if (gfc_option
.flag_whole_file
== 1
2364 || ((gfc_option
.warn_std
& GFC_STD_LEGACY
)
2365 && !(gfc_option
.warn_std
& GFC_STD_GNU
)))
2366 gfc_errors_to_warnings (1);
2368 if (sym
->attr
.if_source
!= IFSRC_IFBODY
)
2369 gfc_procedure_use (def_sym
, actual
, where
);
2371 gfc_errors_to_warnings (0);
2374 if (gsym
->type
== GSYM_UNKNOWN
)
2377 gsym
->where
= *where
;
2384 /************* Function resolution *************/
2386 /* Resolve a function call known to be generic.
2387 Section 14.1.2.4.1. */
2390 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
2394 if (sym
->attr
.generic
)
2396 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
2399 expr
->value
.function
.name
= s
->name
;
2400 expr
->value
.function
.esym
= s
;
2402 if (s
->ts
.type
!= BT_UNKNOWN
)
2404 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
2405 expr
->ts
= s
->result
->ts
;
2408 expr
->rank
= s
->as
->rank
;
2409 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
2410 expr
->rank
= s
->result
->as
->rank
;
2412 gfc_set_sym_referenced (expr
->value
.function
.esym
);
2417 /* TODO: Need to search for elemental references in generic
2421 if (sym
->attr
.intrinsic
)
2422 return gfc_intrinsic_func_interface (expr
, 0);
2429 resolve_generic_f (gfc_expr
*expr
)
2433 gfc_interface
*intr
= NULL
;
2435 sym
= expr
->symtree
->n
.sym
;
2439 m
= resolve_generic_f0 (expr
, sym
);
2442 else if (m
== MATCH_ERROR
)
2447 for (intr
= sym
->generic
; intr
; intr
= intr
->next
)
2448 if (intr
->sym
->attr
.flavor
== FL_DERIVED
)
2451 if (sym
->ns
->parent
== NULL
)
2453 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2457 if (!generic_sym (sym
))
2461 /* Last ditch attempt. See if the reference is to an intrinsic
2462 that possesses a matching interface. 14.1.2.4 */
2463 if (sym
&& !intr
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
2465 gfc_error ("There is no specific function for the generic '%s' "
2466 "at %L", expr
->symtree
->n
.sym
->name
, &expr
->where
);
2472 if (gfc_convert_to_structure_constructor (expr
, intr
->sym
, NULL
, NULL
,
2475 return resolve_structure_cons (expr
, 0);
2478 m
= gfc_intrinsic_func_interface (expr
, 0);
2483 gfc_error ("Generic function '%s' at %L is not consistent with a "
2484 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
2491 /* Resolve a function call known to be specific. */
2494 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
2498 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2500 if (sym
->attr
.dummy
)
2502 sym
->attr
.proc
= PROC_DUMMY
;
2506 sym
->attr
.proc
= PROC_EXTERNAL
;
2510 if (sym
->attr
.proc
== PROC_MODULE
2511 || sym
->attr
.proc
== PROC_ST_FUNCTION
2512 || sym
->attr
.proc
== PROC_INTERNAL
)
2515 if (sym
->attr
.intrinsic
)
2517 m
= gfc_intrinsic_func_interface (expr
, 1);
2521 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
2522 "with an intrinsic", sym
->name
, &expr
->where
);
2530 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2533 expr
->ts
= sym
->result
->ts
;
2536 expr
->value
.function
.name
= sym
->name
;
2537 expr
->value
.function
.esym
= sym
;
2538 if (sym
->as
!= NULL
)
2539 expr
->rank
= sym
->as
->rank
;
2546 resolve_specific_f (gfc_expr
*expr
)
2551 sym
= expr
->symtree
->n
.sym
;
2555 m
= resolve_specific_f0 (sym
, expr
);
2558 if (m
== MATCH_ERROR
)
2561 if (sym
->ns
->parent
== NULL
)
2564 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2570 gfc_error ("Unable to resolve the specific function '%s' at %L",
2571 expr
->symtree
->n
.sym
->name
, &expr
->where
);
2577 /* Resolve a procedure call not known to be generic nor specific. */
2580 resolve_unknown_f (gfc_expr
*expr
)
2585 sym
= expr
->symtree
->n
.sym
;
2587 if (sym
->attr
.dummy
)
2589 sym
->attr
.proc
= PROC_DUMMY
;
2590 expr
->value
.function
.name
= sym
->name
;
2594 /* See if we have an intrinsic function reference. */
2596 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
2598 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
2603 /* The reference is to an external name. */
2605 sym
->attr
.proc
= PROC_EXTERNAL
;
2606 expr
->value
.function
.name
= sym
->name
;
2607 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
2609 if (sym
->as
!= NULL
)
2610 expr
->rank
= sym
->as
->rank
;
2612 /* Type of the expression is either the type of the symbol or the
2613 default type of the symbol. */
2616 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
2618 if (sym
->ts
.type
!= BT_UNKNOWN
)
2622 ts
= gfc_get_default_type (sym
->name
, sym
->ns
);
2624 if (ts
->type
== BT_UNKNOWN
)
2626 gfc_error ("Function '%s' at %L has no IMPLICIT type",
2627 sym
->name
, &expr
->where
);
2638 /* Return true, if the symbol is an external procedure. */
2640 is_external_proc (gfc_symbol
*sym
)
2642 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
2643 && !gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
)
2644 && sym
->attr
.proc
!= PROC_ST_FUNCTION
2645 && !sym
->attr
.proc_pointer
2646 && !sym
->attr
.use_assoc
2654 /* Figure out if a function reference is pure or not. Also set the name
2655 of the function for a potential error message. Return nonzero if the
2656 function is PURE, zero if not. */
2658 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
2661 pure_function (gfc_expr
*e
, const char **name
)
2667 if (e
->symtree
!= NULL
2668 && e
->symtree
->n
.sym
!= NULL
2669 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2670 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
2672 if (e
->value
.function
.esym
)
2674 pure
= gfc_pure (e
->value
.function
.esym
);
2675 *name
= e
->value
.function
.esym
->name
;
2677 else if (e
->value
.function
.isym
)
2679 pure
= e
->value
.function
.isym
->pure
2680 || e
->value
.function
.isym
->elemental
;
2681 *name
= e
->value
.function
.isym
->name
;
2685 /* Implicit functions are not pure. */
2687 *name
= e
->value
.function
.name
;
2695 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
2696 int *f ATTRIBUTE_UNUSED
)
2700 /* Don't bother recursing into other statement functions
2701 since they will be checked individually for purity. */
2702 if (e
->expr_type
!= EXPR_FUNCTION
2704 || e
->symtree
->n
.sym
== sym
2705 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
2708 return pure_function (e
, &name
) ? false : true;
2713 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
2715 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
2720 is_scalar_expr_ptr (gfc_expr
*expr
)
2722 gfc_try retval
= SUCCESS
;
2727 /* See if we have a gfc_ref, which means we have a substring, array
2728 reference, or a component. */
2729 if (expr
->ref
!= NULL
)
2732 while (ref
->next
!= NULL
)
2738 if (ref
->u
.ss
.start
== NULL
|| ref
->u
.ss
.end
== NULL
2739 || gfc_dep_compare_expr (ref
->u
.ss
.start
, ref
->u
.ss
.end
) != 0)
2744 if (ref
->u
.ar
.type
== AR_ELEMENT
)
2746 else if (ref
->u
.ar
.type
== AR_FULL
)
2748 /* The user can give a full array if the array is of size 1. */
2749 if (ref
->u
.ar
.as
!= NULL
2750 && ref
->u
.ar
.as
->rank
== 1
2751 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
2752 && ref
->u
.ar
.as
->lower
[0] != NULL
2753 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
2754 && ref
->u
.ar
.as
->upper
[0] != NULL
2755 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
2757 /* If we have a character string, we need to check if
2758 its length is one. */
2759 if (expr
->ts
.type
== BT_CHARACTER
)
2761 if (expr
->ts
.u
.cl
== NULL
2762 || expr
->ts
.u
.cl
->length
== NULL
2763 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1)
2769 /* We have constant lower and upper bounds. If the
2770 difference between is 1, it can be considered a
2772 FIXME: Use gfc_dep_compare_expr instead. */
2773 start
= (int) mpz_get_si
2774 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2775 end
= (int) mpz_get_si
2776 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2777 if (end
- start
+ 1 != 1)
2792 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2794 /* Character string. Make sure it's of length 1. */
2795 if (expr
->ts
.u
.cl
== NULL
2796 || expr
->ts
.u
.cl
->length
== NULL
2797 || mpz_cmp_si (expr
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
2800 else if (expr
->rank
!= 0)
2807 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2808 and, in the case of c_associated, set the binding label based on
2812 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2813 gfc_symbol
**new_sym
)
2815 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2816 int optional_arg
= 0;
2817 gfc_try retval
= SUCCESS
;
2818 gfc_symbol
*args_sym
;
2819 gfc_typespec
*arg_ts
;
2820 symbol_attribute arg_attr
;
2822 if (args
->expr
->expr_type
== EXPR_CONSTANT
2823 || args
->expr
->expr_type
== EXPR_OP
2824 || args
->expr
->expr_type
== EXPR_NULL
)
2826 gfc_error ("Argument to '%s' at %L is not a variable",
2827 sym
->name
, &(args
->expr
->where
));
2831 args_sym
= args
->expr
->symtree
->n
.sym
;
2833 /* The typespec for the actual arg should be that stored in the expr
2834 and not necessarily that of the expr symbol (args_sym), because
2835 the actual expression could be a part-ref of the expr symbol. */
2836 arg_ts
= &(args
->expr
->ts
);
2837 arg_attr
= gfc_expr_attr (args
->expr
);
2839 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2841 /* If the user gave two args then they are providing something for
2842 the optional arg (the second cptr). Therefore, set the name and
2843 binding label to the c_associated for two cptrs. Otherwise,
2844 set c_associated to expect one cptr. */
2848 sprintf (name
, "%s_2", sym
->name
);
2854 sprintf (name
, "%s_1", sym
->name
);
2858 /* Get a new symbol for the version of c_associated that
2860 *new_sym
= get_iso_c_sym (sym
, name
, NULL
, optional_arg
);
2862 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2863 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2865 sprintf (name
, "%s", sym
->name
);
2867 /* Error check the call. */
2868 if (args
->next
!= NULL
)
2870 gfc_error_now ("More actual than formal arguments in '%s' "
2871 "call at %L", name
, &(args
->expr
->where
));
2874 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2879 /* Make sure we have either the target or pointer attribute. */
2880 if (!arg_attr
.target
&& !arg_attr
.pointer
)
2882 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2883 "a TARGET or an associated pointer",
2885 sym
->name
, &(args
->expr
->where
));
2889 if (gfc_is_coindexed (args
->expr
))
2891 gfc_error_now ("Coindexed argument not permitted"
2892 " in '%s' call at %L", name
,
2893 &(args
->expr
->where
));
2897 /* Follow references to make sure there are no array
2899 seen_section
= false;
2901 for (ref
=args
->expr
->ref
; ref
; ref
= ref
->next
)
2903 if (ref
->type
== REF_ARRAY
)
2905 if (ref
->u
.ar
.type
== AR_SECTION
)
2906 seen_section
= true;
2908 if (ref
->u
.ar
.type
!= AR_ELEMENT
)
2911 for (r
= ref
->next
; r
; r
=r
->next
)
2912 if (r
->type
== REF_COMPONENT
)
2914 gfc_error_now ("Array section not permitted"
2915 " in '%s' call at %L", name
,
2916 &(args
->expr
->where
));
2924 if (seen_section
&& retval
== SUCCESS
)
2925 gfc_warning ("Array section in '%s' call at %L", name
,
2926 &(args
->expr
->where
));
2928 /* See if we have interoperable type and type param. */
2929 if (gfc_verify_c_interop (arg_ts
) == SUCCESS
2930 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2932 if (args_sym
->attr
.target
== 1)
2934 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2935 has the target attribute and is interoperable. */
2936 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2937 allocatable variable that has the TARGET attribute and
2938 is not an array of zero size. */
2939 if (args_sym
->attr
.allocatable
== 1)
2941 if (args_sym
->attr
.dimension
!= 0
2942 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2944 gfc_error_now ("Allocatable variable '%s' used as a "
2945 "parameter to '%s' at %L must not be "
2946 "an array of zero size",
2947 args_sym
->name
, sym
->name
,
2948 &(args
->expr
->where
));
2954 /* A non-allocatable target variable with C
2955 interoperable type and type parameters must be
2957 if (args_sym
&& args_sym
->attr
.dimension
)
2959 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2961 gfc_error ("Assumed-shape array '%s' at %L "
2962 "cannot be an argument to the "
2963 "procedure '%s' because "
2964 "it is not C interoperable",
2966 &(args
->expr
->where
), sym
->name
);
2969 else if (args_sym
->as
->type
== AS_DEFERRED
)
2971 gfc_error ("Deferred-shape array '%s' at %L "
2972 "cannot be an argument to the "
2973 "procedure '%s' because "
2974 "it is not C interoperable",
2976 &(args
->expr
->where
), sym
->name
);
2981 /* Make sure it's not a character string. Arrays of
2982 any type should be ok if the variable is of a C
2983 interoperable type. */
2984 if (arg_ts
->type
== BT_CHARACTER
)
2985 if (arg_ts
->u
.cl
!= NULL
2986 && (arg_ts
->u
.cl
->length
== NULL
2987 || arg_ts
->u
.cl
->length
->expr_type
2990 (arg_ts
->u
.cl
->length
->value
.integer
, 1)
2992 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2994 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2995 "at %L must have a length of 1",
2996 args_sym
->name
, sym
->name
,
2997 &(args
->expr
->where
));
3002 else if (arg_attr
.pointer
3003 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3005 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
3007 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
3008 "associated scalar POINTER", args_sym
->name
,
3009 sym
->name
, &(args
->expr
->where
));
3015 /* The parameter is not required to be C interoperable. If it
3016 is not C interoperable, it must be a nonpolymorphic scalar
3017 with no length type parameters. It still must have either
3018 the pointer or target attribute, and it can be
3019 allocatable (but must be allocated when c_loc is called). */
3020 if (args
->expr
->rank
!= 0
3021 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3023 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
3024 "scalar", args_sym
->name
, sym
->name
,
3025 &(args
->expr
->where
));
3028 else if (arg_ts
->type
== BT_CHARACTER
3029 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
3031 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
3032 "%L must have a length of 1",
3033 args_sym
->name
, sym
->name
,
3034 &(args
->expr
->where
));
3037 else if (arg_ts
->type
== BT_CLASS
)
3039 gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
3040 "polymorphic", args_sym
->name
, sym
->name
,
3041 &(args
->expr
->where
));
3046 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
3048 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
3050 /* TODO: Update this error message to allow for procedure
3051 pointers once they are implemented. */
3052 gfc_error_now ("Argument '%s' to '%s' at %L must be a "
3054 args_sym
->name
, sym
->name
,
3055 &(args
->expr
->where
));
3058 else if (args_sym
->attr
.is_bind_c
!= 1
3059 && gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable "
3060 "argument '%s' to '%s' at %L",
3061 args_sym
->name
, sym
->name
,
3062 &(args
->expr
->where
)) == FAILURE
)
3066 /* for c_loc/c_funloc, the new symbol is the same as the old one */
3071 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
3072 "iso_c_binding function: '%s'!\n", sym
->name
);
3079 /* Resolve a function call, which means resolving the arguments, then figuring
3080 out which entity the name refers to. */
3083 resolve_function (gfc_expr
*expr
)
3085 gfc_actual_arglist
*arg
;
3090 procedure_type p
= PROC_INTRINSIC
;
3091 bool no_formal_args
;
3095 sym
= expr
->symtree
->n
.sym
;
3097 /* If this is a procedure pointer component, it has already been resolved. */
3098 if (gfc_is_proc_ptr_comp (expr
))
3101 if (sym
&& sym
->attr
.intrinsic
3102 && gfc_resolve_intrinsic (sym
, &expr
->where
) == FAILURE
)
3105 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
3107 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
3111 /* If this ia a deferred TBP with an abstract interface (which may
3112 of course be referenced), expr->value.function.esym will be set. */
3113 if (sym
&& sym
->attr
.abstract
&& !expr
->value
.function
.esym
)
3115 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3116 sym
->name
, &expr
->where
);
3120 /* Switch off assumed size checking and do this again for certain kinds
3121 of procedure, once the procedure itself is resolved. */
3122 need_full_assumed_size
++;
3124 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
3125 p
= expr
->symtree
->n
.sym
->attr
.proc
;
3127 if (expr
->value
.function
.isym
&& expr
->value
.function
.isym
->inquiry
)
3128 inquiry_argument
= true;
3129 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
3131 if (resolve_actual_arglist (expr
->value
.function
.actual
,
3132 p
, no_formal_args
) == FAILURE
)
3134 inquiry_argument
= false;
3138 inquiry_argument
= false;
3140 /* Need to setup the call to the correct c_associated, depending on
3141 the number of cptrs to user gives to compare. */
3142 if (sym
&& sym
->attr
.is_iso_c
== 1)
3144 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
3148 /* Get the symtree for the new symbol (resolved func).
3149 the old one will be freed later, when it's no longer used. */
3150 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
3153 /* Resume assumed_size checking. */
3154 need_full_assumed_size
--;
3156 /* If the procedure is external, check for usage. */
3157 if (sym
&& is_external_proc (sym
))
3158 resolve_global_procedure (sym
, &expr
->where
,
3159 &expr
->value
.function
.actual
, 0);
3161 if (sym
&& sym
->ts
.type
== BT_CHARACTER
3163 && sym
->ts
.u
.cl
->length
== NULL
3165 && !sym
->ts
.deferred
3166 && expr
->value
.function
.esym
== NULL
3167 && !sym
->attr
.contained
)
3169 /* Internal procedures are taken care of in resolve_contained_fntype. */
3170 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
3171 "be used at %L since it is not a dummy argument",
3172 sym
->name
, &expr
->where
);
3176 /* See if function is already resolved. */
3178 if (expr
->value
.function
.name
!= NULL
)
3180 if (expr
->ts
.type
== BT_UNKNOWN
)
3186 /* Apply the rules of section 14.1.2. */
3188 switch (procedure_kind (sym
))
3191 t
= resolve_generic_f (expr
);
3194 case PTYPE_SPECIFIC
:
3195 t
= resolve_specific_f (expr
);
3199 t
= resolve_unknown_f (expr
);
3203 gfc_internal_error ("resolve_function(): bad function type");
3207 /* If the expression is still a function (it might have simplified),
3208 then we check to see if we are calling an elemental function. */
3210 if (expr
->expr_type
!= EXPR_FUNCTION
)
3213 temp
= need_full_assumed_size
;
3214 need_full_assumed_size
= 0;
3216 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
3219 if (omp_workshare_flag
3220 && expr
->value
.function
.esym
3221 && ! gfc_elemental (expr
->value
.function
.esym
))
3223 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
3224 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
3229 #define GENERIC_ID expr->value.function.isym->id
3230 else if (expr
->value
.function
.actual
!= NULL
3231 && expr
->value
.function
.isym
!= NULL
3232 && GENERIC_ID
!= GFC_ISYM_LBOUND
3233 && GENERIC_ID
!= GFC_ISYM_LEN
3234 && GENERIC_ID
!= GFC_ISYM_LOC
3235 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
3237 /* Array intrinsics must also have the last upper bound of an
3238 assumed size array argument. UBOUND and SIZE have to be
3239 excluded from the check if the second argument is anything
3242 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
3244 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
3245 && arg
->next
!= NULL
&& arg
->next
->expr
)
3247 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
3250 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
3253 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
3258 if (arg
->expr
!= NULL
3259 && arg
->expr
->rank
> 0
3260 && resolve_assumed_size_actual (arg
->expr
))
3266 need_full_assumed_size
= temp
;
3269 if (!pure_function (expr
, &name
) && name
)
3273 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3274 "FORALL %s", name
, &expr
->where
,
3275 forall_flag
== 2 ? "mask" : "block");
3278 else if (do_concurrent_flag
)
3280 gfc_error ("Reference to non-PURE function '%s' at %L inside a "
3281 "DO CONCURRENT %s", name
, &expr
->where
,
3282 do_concurrent_flag
== 2 ? "mask" : "block");
3285 else if (gfc_pure (NULL
))
3287 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
3288 "procedure within a PURE procedure", name
, &expr
->where
);
3292 if (gfc_implicit_pure (NULL
))
3293 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3296 /* Functions without the RECURSIVE attribution are not allowed to
3297 * call themselves. */
3298 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
3301 esym
= expr
->value
.function
.esym
;
3303 if (is_illegal_recursion (esym
, gfc_current_ns
))
3305 if (esym
->attr
.entry
&& esym
->ns
->entries
)
3306 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3307 " function '%s' is not RECURSIVE",
3308 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
3310 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
3311 " is not RECURSIVE", esym
->name
, &expr
->where
);
3317 /* Character lengths of use associated functions may contains references to
3318 symbols not referenced from the current program unit otherwise. Make sure
3319 those symbols are marked as referenced. */
3321 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
3322 && expr
->value
.function
.esym
->attr
.use_assoc
)
3324 gfc_expr_set_symbols_referenced (expr
->ts
.u
.cl
->length
);
3327 /* Make sure that the expression has a typespec that works. */
3328 if (expr
->ts
.type
== BT_UNKNOWN
)
3330 if (expr
->symtree
->n
.sym
->result
3331 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
3332 && !expr
->symtree
->n
.sym
->result
->attr
.proc_pointer
)
3333 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
3340 /************* Subroutine resolution *************/
3343 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
3349 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
3350 sym
->name
, &c
->loc
);
3351 else if (do_concurrent_flag
)
3352 gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not "
3353 "PURE", sym
->name
, &c
->loc
);
3354 else if (gfc_pure (NULL
))
3355 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
3358 if (gfc_implicit_pure (NULL
))
3359 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
3364 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3368 if (sym
->attr
.generic
)
3370 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
3373 c
->resolved_sym
= s
;
3374 pure_subroutine (c
, s
);
3378 /* TODO: Need to search for elemental references in generic interface. */
3381 if (sym
->attr
.intrinsic
)
3382 return gfc_intrinsic_sub_interface (c
, 0);
3389 resolve_generic_s (gfc_code
*c
)
3394 sym
= c
->symtree
->n
.sym
;
3398 m
= resolve_generic_s0 (c
, sym
);
3401 else if (m
== MATCH_ERROR
)
3405 if (sym
->ns
->parent
== NULL
)
3407 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3411 if (!generic_sym (sym
))
3415 /* Last ditch attempt. See if the reference is to an intrinsic
3416 that possesses a matching interface. 14.1.2.4 */
3417 sym
= c
->symtree
->n
.sym
;
3419 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
3421 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
3422 sym
->name
, &c
->loc
);
3426 m
= gfc_intrinsic_sub_interface (c
, 0);
3430 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
3431 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
3437 /* Set the name and binding label of the subroutine symbol in the call
3438 expression represented by 'c' to include the type and kind of the
3439 second parameter. This function is for resolving the appropriate
3440 version of c_f_pointer() and c_f_procpointer(). For example, a
3441 call to c_f_pointer() for a default integer pointer could have a
3442 name of c_f_pointer_i4. If no second arg exists, which is an error
3443 for these two functions, it defaults to the generic symbol's name
3444 and binding label. */
3447 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
3448 char *name
, const char **binding_label
)
3450 gfc_expr
*arg
= NULL
;
3454 /* The second arg of c_f_pointer and c_f_procpointer determines
3455 the type and kind for the procedure name. */
3456 arg
= c
->ext
.actual
->next
->expr
;
3460 /* Set up the name to have the given symbol's name,
3461 plus the type and kind. */
3462 /* a derived type is marked with the type letter 'u' */
3463 if (arg
->ts
.type
== BT_DERIVED
)
3466 kind
= 0; /* set the kind as 0 for now */
3470 type
= gfc_type_letter (arg
->ts
.type
);
3471 kind
= arg
->ts
.kind
;
3474 if (arg
->ts
.type
== BT_CHARACTER
)
3475 /* Kind info for character strings not needed. */
3478 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
3479 /* Set up the binding label as the given symbol's label plus
3480 the type and kind. */
3481 *binding_label
= gfc_get_string ("%s_%c%d", sym
->binding_label
, type
,
3486 /* If the second arg is missing, set the name and label as
3487 was, cause it should at least be found, and the missing
3488 arg error will be caught by compare_parameters(). */
3489 sprintf (name
, "%s", sym
->name
);
3490 *binding_label
= sym
->binding_label
;
3497 /* Resolve a generic version of the iso_c_binding procedure given
3498 (sym) to the specific one based on the type and kind of the
3499 argument(s). Currently, this function resolves c_f_pointer() and
3500 c_f_procpointer based on the type and kind of the second argument
3501 (FPTR). Other iso_c_binding procedures aren't specially handled.
3502 Upon successfully exiting, c->resolved_sym will hold the resolved
3503 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
3507 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
3509 gfc_symbol
*new_sym
;
3510 /* this is fine, since we know the names won't use the max */
3511 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3512 const char* binding_label
;
3513 /* default to success; will override if find error */
3514 match m
= MATCH_YES
;
3516 /* Make sure the actual arguments are in the necessary order (based on the
3517 formal args) before resolving. */
3518 if (gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
)) == FAILURE
)
3520 c
->resolved_sym
= sym
;
3524 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
3525 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
3527 set_name_and_label (c
, sym
, name
, &binding_label
);
3529 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
3531 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
3533 if (c
->ext
.actual
->expr
->ts
.type
!= BT_DERIVED
3534 || c
->ext
.actual
->expr
->ts
.u
.derived
->intmod_sym_id
3537 gfc_error ("Argument at %L to C_F_POINTER shall have the type"
3538 " C_PTR", &c
->ext
.actual
->expr
->where
);
3542 /* Make sure we got a third arg if the second arg has non-zero
3543 rank. We must also check that the type and rank are
3544 correct since we short-circuit this check in
3545 gfc_procedure_use() (called above to sort actual args). */
3546 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
3548 if(c
->ext
.actual
->next
->next
== NULL
3549 || c
->ext
.actual
->next
->next
->expr
== NULL
)
3552 gfc_error ("Missing SHAPE parameter for call to %s "
3553 "at %L", sym
->name
, &(c
->loc
));
3555 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
3557 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
3560 gfc_error ("SHAPE parameter for call to %s at %L must "
3561 "be a rank 1 INTEGER array", sym
->name
,
3567 else /* ISOCBINDING_F_PROCPOINTER. */
3570 && (c
->ext
.actual
->expr
->ts
.type
!= BT_DERIVED
3571 || c
->ext
.actual
->expr
->ts
.u
.derived
->intmod_sym_id
3572 != ISOCBINDING_FUNPTR
))
3574 gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
3575 "C_FUNPTR", &c
->ext
.actual
->expr
->where
);
3578 if (c
->ext
.actual
&& c
->ext
.actual
->next
3579 && !gfc_expr_attr (c
->ext
.actual
->next
->expr
).is_bind_c
3580 && gfc_notify_std (GFC_STD_F2008_TS
, "Noninteroperable "
3581 "procedure-pointer at %L to C_F_FUNPOINTER",
3582 &c
->ext
.actual
->next
->expr
->where
)
3587 if (m
!= MATCH_ERROR
)
3589 /* the 1 means to add the optional arg to formal list */
3590 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
3592 /* for error reporting, say it's declared where the original was */
3593 new_sym
->declared_at
= sym
->declared_at
;
3598 /* no differences for c_loc or c_funloc */
3602 /* set the resolved symbol */
3603 if (m
!= MATCH_ERROR
)
3604 c
->resolved_sym
= new_sym
;
3606 c
->resolved_sym
= sym
;
3612 /* Resolve a subroutine call known to be specific. */
3615 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
3619 if(sym
->attr
.is_iso_c
)
3621 m
= gfc_iso_c_sub_interface (c
,sym
);
3625 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
3627 if (sym
->attr
.dummy
)
3629 sym
->attr
.proc
= PROC_DUMMY
;
3633 sym
->attr
.proc
= PROC_EXTERNAL
;
3637 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
3640 if (sym
->attr
.intrinsic
)
3642 m
= gfc_intrinsic_sub_interface (c
, 1);
3646 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
3647 "with an intrinsic", sym
->name
, &c
->loc
);
3655 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3657 c
->resolved_sym
= sym
;
3658 pure_subroutine (c
, sym
);
3665 resolve_specific_s (gfc_code
*c
)
3670 sym
= c
->symtree
->n
.sym
;
3674 m
= resolve_specific_s0 (c
, sym
);
3677 if (m
== MATCH_ERROR
)
3680 if (sym
->ns
->parent
== NULL
)
3683 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
3689 sym
= c
->symtree
->n
.sym
;
3690 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
3691 sym
->name
, &c
->loc
);
3697 /* Resolve a subroutine call not known to be generic nor specific. */
3700 resolve_unknown_s (gfc_code
*c
)
3704 sym
= c
->symtree
->n
.sym
;
3706 if (sym
->attr
.dummy
)
3708 sym
->attr
.proc
= PROC_DUMMY
;
3712 /* See if we have an intrinsic function reference. */
3714 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
3716 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
3721 /* The reference is to an external name. */
3724 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
3726 c
->resolved_sym
= sym
;
3728 pure_subroutine (c
, sym
);
3734 /* Resolve a subroutine call. Although it was tempting to use the same code
3735 for functions, subroutines and functions are stored differently and this
3736 makes things awkward. */
3739 resolve_call (gfc_code
*c
)
3742 procedure_type ptype
= PROC_INTRINSIC
;
3743 gfc_symbol
*csym
, *sym
;
3744 bool no_formal_args
;
3746 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
3748 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
3750 gfc_error ("'%s' at %L has a type, which is not consistent with "
3751 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
3755 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
3758 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
3759 sym
= st
? st
->n
.sym
: NULL
;
3760 if (sym
&& csym
!= sym
3761 && sym
->ns
== gfc_current_ns
3762 && sym
->attr
.flavor
== FL_PROCEDURE
3763 && sym
->attr
.contained
)
3766 if (csym
->attr
.generic
)
3767 c
->symtree
->n
.sym
= sym
;
3770 csym
= c
->symtree
->n
.sym
;
3774 /* If this ia a deferred TBP with an abstract interface
3775 (which may of course be referenced), c->expr1 will be set. */
3776 if (csym
&& csym
->attr
.abstract
&& !c
->expr1
)
3778 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
3779 csym
->name
, &c
->loc
);
3783 /* Subroutines without the RECURSIVE attribution are not allowed to
3784 * call themselves. */
3785 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
3787 if (csym
->attr
.entry
&& csym
->ns
->entries
)
3788 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
3789 " subroutine '%s' is not RECURSIVE",
3790 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
3792 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
3793 " is not RECURSIVE", csym
->name
, &c
->loc
);
3798 /* Switch off assumed size checking and do this again for certain kinds
3799 of procedure, once the procedure itself is resolved. */
3800 need_full_assumed_size
++;
3803 ptype
= csym
->attr
.proc
;
3805 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
3806 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
3807 no_formal_args
) == FAILURE
)
3810 /* Resume assumed_size checking. */
3811 need_full_assumed_size
--;
3813 /* If external, check for usage. */
3814 if (csym
&& is_external_proc (csym
))
3815 resolve_global_procedure (csym
, &c
->loc
, &c
->ext
.actual
, 1);
3818 if (c
->resolved_sym
== NULL
)
3820 c
->resolved_isym
= NULL
;
3821 switch (procedure_kind (csym
))
3824 t
= resolve_generic_s (c
);
3827 case PTYPE_SPECIFIC
:
3828 t
= resolve_specific_s (c
);
3832 t
= resolve_unknown_s (c
);
3836 gfc_internal_error ("resolve_subroutine(): bad function type");
3840 /* Some checks of elemental subroutine actual arguments. */
3841 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
3848 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3849 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3850 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3851 if their shapes do not match. If either op1->shape or op2->shape is
3852 NULL, return SUCCESS. */
3855 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3862 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3864 for (i
= 0; i
< op1
->rank
; i
++)
3866 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3868 gfc_error ("Shapes for operands at %L and %L are not conformable",
3869 &op1
->where
, &op2
->where
);
3880 /* Resolve an operator expression node. This can involve replacing the
3881 operation with a user defined function call. */
3884 resolve_operator (gfc_expr
*e
)
3886 gfc_expr
*op1
, *op2
;
3888 bool dual_locus_error
;
3891 /* Resolve all subnodes-- give them types. */
3893 switch (e
->value
.op
.op
)
3896 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3899 /* Fall through... */
3902 case INTRINSIC_UPLUS
:
3903 case INTRINSIC_UMINUS
:
3904 case INTRINSIC_PARENTHESES
:
3905 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3910 /* Typecheck the new node. */
3912 op1
= e
->value
.op
.op1
;
3913 op2
= e
->value
.op
.op2
;
3914 dual_locus_error
= false;
3916 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3917 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3919 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3923 switch (e
->value
.op
.op
)
3925 case INTRINSIC_UPLUS
:
3926 case INTRINSIC_UMINUS
:
3927 if (op1
->ts
.type
== BT_INTEGER
3928 || op1
->ts
.type
== BT_REAL
3929 || op1
->ts
.type
== BT_COMPLEX
)
3935 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3936 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3939 case INTRINSIC_PLUS
:
3940 case INTRINSIC_MINUS
:
3941 case INTRINSIC_TIMES
:
3942 case INTRINSIC_DIVIDE
:
3943 case INTRINSIC_POWER
:
3944 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3946 gfc_type_convert_binary (e
, 1);
3951 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3952 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3953 gfc_typename (&op2
->ts
));
3956 case INTRINSIC_CONCAT
:
3957 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3958 && op1
->ts
.kind
== op2
->ts
.kind
)
3960 e
->ts
.type
= BT_CHARACTER
;
3961 e
->ts
.kind
= op1
->ts
.kind
;
3966 _("Operands of string concatenation operator at %%L are %s/%s"),
3967 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3973 case INTRINSIC_NEQV
:
3974 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3976 e
->ts
.type
= BT_LOGICAL
;
3977 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3978 if (op1
->ts
.kind
< e
->ts
.kind
)
3979 gfc_convert_type (op1
, &e
->ts
, 2);
3980 else if (op2
->ts
.kind
< e
->ts
.kind
)
3981 gfc_convert_type (op2
, &e
->ts
, 2);
3985 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3986 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3987 gfc_typename (&op2
->ts
));
3992 if (op1
->ts
.type
== BT_LOGICAL
)
3994 e
->ts
.type
= BT_LOGICAL
;
3995 e
->ts
.kind
= op1
->ts
.kind
;
3999 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
4000 gfc_typename (&op1
->ts
));
4004 case INTRINSIC_GT_OS
:
4006 case INTRINSIC_GE_OS
:
4008 case INTRINSIC_LT_OS
:
4010 case INTRINSIC_LE_OS
:
4011 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
4013 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
4017 /* Fall through... */
4020 case INTRINSIC_EQ_OS
:
4022 case INTRINSIC_NE_OS
:
4023 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
4024 && op1
->ts
.kind
== op2
->ts
.kind
)
4026 e
->ts
.type
= BT_LOGICAL
;
4027 e
->ts
.kind
= gfc_default_logical_kind
;
4031 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
4033 gfc_type_convert_binary (e
, 1);
4035 e
->ts
.type
= BT_LOGICAL
;
4036 e
->ts
.kind
= gfc_default_logical_kind
;
4038 if (gfc_option
.warn_compare_reals
)
4040 gfc_intrinsic_op op
= e
->value
.op
.op
;
4042 /* Type conversion has made sure that the types of op1 and op2
4043 agree, so it is only necessary to check the first one. */
4044 if ((op1
->ts
.type
== BT_REAL
|| op1
->ts
.type
== BT_COMPLEX
)
4045 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
4046 || op
== INTRINSIC_NE
|| op
== INTRINSIC_NE_OS
))
4050 if (op
== INTRINSIC_EQ
|| op
== INTRINSIC_EQ_OS
)
4051 msg
= "Equality comparison for %s at %L";
4053 msg
= "Inequality comparison for %s at %L";
4055 gfc_warning (msg
, gfc_typename (&op1
->ts
), &op1
->where
);
4062 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
4064 _("Logicals at %%L must be compared with %s instead of %s"),
4065 (e
->value
.op
.op
== INTRINSIC_EQ
4066 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
4067 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
4070 _("Operands of comparison operator '%s' at %%L are %s/%s"),
4071 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
4072 gfc_typename (&op2
->ts
));
4076 case INTRINSIC_USER
:
4077 if (e
->value
.op
.uop
->op
== NULL
)
4078 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
4079 else if (op2
== NULL
)
4080 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
4081 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
4084 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
4085 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
4086 gfc_typename (&op2
->ts
));
4087 e
->value
.op
.uop
->op
->sym
->attr
.referenced
= 1;
4092 case INTRINSIC_PARENTHESES
:
4094 if (e
->ts
.type
== BT_CHARACTER
)
4095 e
->ts
.u
.cl
= op1
->ts
.u
.cl
;
4099 gfc_internal_error ("resolve_operator(): Bad intrinsic");
4102 /* Deal with arrayness of an operand through an operator. */
4106 switch (e
->value
.op
.op
)
4108 case INTRINSIC_PLUS
:
4109 case INTRINSIC_MINUS
:
4110 case INTRINSIC_TIMES
:
4111 case INTRINSIC_DIVIDE
:
4112 case INTRINSIC_POWER
:
4113 case INTRINSIC_CONCAT
:
4117 case INTRINSIC_NEQV
:
4119 case INTRINSIC_EQ_OS
:
4121 case INTRINSIC_NE_OS
:
4123 case INTRINSIC_GT_OS
:
4125 case INTRINSIC_GE_OS
:
4127 case INTRINSIC_LT_OS
:
4129 case INTRINSIC_LE_OS
:
4131 if (op1
->rank
== 0 && op2
->rank
== 0)
4134 if (op1
->rank
== 0 && op2
->rank
!= 0)
4136 e
->rank
= op2
->rank
;
4138 if (e
->shape
== NULL
)
4139 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
4142 if (op1
->rank
!= 0 && op2
->rank
== 0)
4144 e
->rank
= op1
->rank
;
4146 if (e
->shape
== NULL
)
4147 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4150 if (op1
->rank
!= 0 && op2
->rank
!= 0)
4152 if (op1
->rank
== op2
->rank
)
4154 e
->rank
= op1
->rank
;
4155 if (e
->shape
== NULL
)
4157 t
= compare_shapes (op1
, op2
);
4161 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4166 /* Allow higher level expressions to work. */
4169 /* Try user-defined operators, and otherwise throw an error. */
4170 dual_locus_error
= true;
4172 _("Inconsistent ranks for operator at %%L and %%L"));
4179 case INTRINSIC_PARENTHESES
:
4181 case INTRINSIC_UPLUS
:
4182 case INTRINSIC_UMINUS
:
4183 /* Simply copy arrayness attribute */
4184 e
->rank
= op1
->rank
;
4186 if (e
->shape
== NULL
)
4187 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
4195 /* Attempt to simplify the expression. */
4198 t
= gfc_simplify_expr (e
, 0);
4199 /* Some calls do not succeed in simplification and return FAILURE
4200 even though there is no error; e.g. variable references to
4201 PARAMETER arrays. */
4202 if (!gfc_is_constant_expr (e
))
4210 match m
= gfc_extend_expr (e
);
4213 if (m
== MATCH_ERROR
)
4217 if (dual_locus_error
)
4218 gfc_error (msg
, &op1
->where
, &op2
->where
);
4220 gfc_error (msg
, &e
->where
);
4226 /************** Array resolution subroutines **************/
4229 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
4232 /* Compare two integer expressions. */
4235 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
4239 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
4240 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
4243 /* If either of the types isn't INTEGER, we must have
4244 raised an error earlier. */
4246 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
4249 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
4259 /* Compare an integer expression with an integer. */
4262 compare_bound_int (gfc_expr
*a
, int b
)
4266 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4269 if (a
->ts
.type
!= BT_INTEGER
)
4270 gfc_internal_error ("compare_bound_int(): Bad expression");
4272 i
= mpz_cmp_si (a
->value
.integer
, b
);
4282 /* Compare an integer expression with a mpz_t. */
4285 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
4289 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
4292 if (a
->ts
.type
!= BT_INTEGER
)
4293 gfc_internal_error ("compare_bound_int(): Bad expression");
4295 i
= mpz_cmp (a
->value
.integer
, b
);
4305 /* Compute the last value of a sequence given by a triplet.
4306 Return 0 if it wasn't able to compute the last value, or if the
4307 sequence if empty, and 1 otherwise. */
4310 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
4311 gfc_expr
*stride
, mpz_t last
)
4315 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
4316 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
4317 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
4320 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
4321 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
4324 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
4326 if (compare_bound (start
, end
) == CMP_GT
)
4328 mpz_set (last
, end
->value
.integer
);
4332 if (compare_bound_int (stride
, 0) == CMP_GT
)
4334 /* Stride is positive */
4335 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
4340 /* Stride is negative */
4341 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
4346 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
4347 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
4348 mpz_sub (last
, end
->value
.integer
, rem
);
4355 /* Compare a single dimension of an array reference to the array
4359 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
4363 if (ar
->dimen_type
[i
] == DIMEN_STAR
)
4365 gcc_assert (ar
->stride
[i
] == NULL
);
4366 /* This implies [*] as [*:] and [*:3] are not possible. */
4367 if (ar
->start
[i
] == NULL
)
4369 gcc_assert (ar
->end
[i
] == NULL
);
4374 /* Given start, end and stride values, calculate the minimum and
4375 maximum referenced indexes. */
4377 switch (ar
->dimen_type
[i
])
4380 case DIMEN_THIS_IMAGE
:
4385 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
4388 gfc_warning ("Array reference at %L is out of bounds "
4389 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4390 mpz_get_si (ar
->start
[i
]->value
.integer
),
4391 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4393 gfc_warning ("Array reference at %L is out of bounds "
4394 "(%ld < %ld) in codimension %d", &ar
->c_where
[i
],
4395 mpz_get_si (ar
->start
[i
]->value
.integer
),
4396 mpz_get_si (as
->lower
[i
]->value
.integer
),
4400 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
4403 gfc_warning ("Array reference at %L is out of bounds "
4404 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4405 mpz_get_si (ar
->start
[i
]->value
.integer
),
4406 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4408 gfc_warning ("Array reference at %L is out of bounds "
4409 "(%ld > %ld) in codimension %d", &ar
->c_where
[i
],
4410 mpz_get_si (ar
->start
[i
]->value
.integer
),
4411 mpz_get_si (as
->upper
[i
]->value
.integer
),
4420 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
4421 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
4423 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
4425 /* Check for zero stride, which is not allowed. */
4426 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
4428 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
4432 /* if start == len || (stride > 0 && start < len)
4433 || (stride < 0 && start > len),
4434 then the array section contains at least one element. In this
4435 case, there is an out-of-bounds access if
4436 (start < lower || start > upper). */
4437 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
4438 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
4439 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
4440 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
4441 && comp_start_end
== CMP_GT
))
4443 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
4445 gfc_warning ("Lower array reference at %L is out of bounds "
4446 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4447 mpz_get_si (AR_START
->value
.integer
),
4448 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4451 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
4453 gfc_warning ("Lower array reference at %L is out of bounds "
4454 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4455 mpz_get_si (AR_START
->value
.integer
),
4456 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4461 /* If we can compute the highest index of the array section,
4462 then it also has to be between lower and upper. */
4463 mpz_init (last_value
);
4464 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
4467 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
4469 gfc_warning ("Upper array reference at %L is out of bounds "
4470 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
4471 mpz_get_si (last_value
),
4472 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
4473 mpz_clear (last_value
);
4476 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
4478 gfc_warning ("Upper array reference at %L is out of bounds "
4479 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
4480 mpz_get_si (last_value
),
4481 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
4482 mpz_clear (last_value
);
4486 mpz_clear (last_value
);
4494 gfc_internal_error ("check_dimension(): Bad array reference");
4501 /* Compare an array reference with an array specification. */
4504 compare_spec_to_ref (gfc_array_ref
*ar
)
4511 /* TODO: Full array sections are only allowed as actual parameters. */
4512 if (as
->type
== AS_ASSUMED_SIZE
4513 && (/*ar->type == AR_FULL
4514 ||*/ (ar
->type
== AR_SECTION
4515 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
4517 gfc_error ("Rightmost upper bound of assumed size array section "
4518 "not specified at %L", &ar
->where
);
4522 if (ar
->type
== AR_FULL
)
4525 if (as
->rank
!= ar
->dimen
)
4527 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
4528 &ar
->where
, ar
->dimen
, as
->rank
);
4532 /* ar->codimen == 0 is a local array. */
4533 if (as
->corank
!= ar
->codimen
&& ar
->codimen
!= 0)
4535 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)",
4536 &ar
->where
, ar
->codimen
, as
->corank
);
4540 for (i
= 0; i
< as
->rank
; i
++)
4541 if (check_dimension (i
, ar
, as
) == FAILURE
)
4544 /* Local access has no coarray spec. */
4545 if (ar
->codimen
!= 0)
4546 for (i
= as
->rank
; i
< as
->rank
+ as
->corank
; i
++)
4548 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
&& !ar
->in_allocate
4549 && ar
->dimen_type
[i
] != DIMEN_THIS_IMAGE
)
4551 gfc_error ("Coindex of codimension %d must be a scalar at %L",
4552 i
+ 1 - as
->rank
, &ar
->where
);
4555 if (check_dimension (i
, ar
, as
) == FAILURE
)
4563 /* Resolve one part of an array index. */
4566 gfc_resolve_index_1 (gfc_expr
*index
, int check_scalar
,
4567 int force_index_integer_kind
)
4574 if (gfc_resolve_expr (index
) == FAILURE
)
4577 if (check_scalar
&& index
->rank
!= 0)
4579 gfc_error ("Array index at %L must be scalar", &index
->where
);
4583 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
4585 gfc_error ("Array index at %L must be of INTEGER type, found %s",
4586 &index
->where
, gfc_basic_typename (index
->ts
.type
));
4590 if (index
->ts
.type
== BT_REAL
)
4591 if (gfc_notify_std (GFC_STD_LEGACY
, "REAL array index at %L",
4592 &index
->where
) == FAILURE
)
4595 if ((index
->ts
.kind
!= gfc_index_integer_kind
4596 && force_index_integer_kind
)
4597 || index
->ts
.type
!= BT_INTEGER
)
4600 ts
.type
= BT_INTEGER
;
4601 ts
.kind
= gfc_index_integer_kind
;
4603 gfc_convert_type_warn (index
, &ts
, 2, 0);
4609 /* Resolve one part of an array index. */
4612 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
4614 return gfc_resolve_index_1 (index
, check_scalar
, 1);
4617 /* Resolve a dim argument to an intrinsic function. */
4620 gfc_resolve_dim_arg (gfc_expr
*dim
)
4625 if (gfc_resolve_expr (dim
) == FAILURE
)
4630 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
4635 if (dim
->ts
.type
!= BT_INTEGER
)
4637 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
4641 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
4646 ts
.type
= BT_INTEGER
;
4647 ts
.kind
= gfc_index_integer_kind
;
4649 gfc_convert_type_warn (dim
, &ts
, 2, 0);
4655 /* Given an expression that contains array references, update those array
4656 references to point to the right array specifications. While this is
4657 filled in during matching, this information is difficult to save and load
4658 in a module, so we take care of it here.
4660 The idea here is that the original array reference comes from the
4661 base symbol. We traverse the list of reference structures, setting
4662 the stored reference to references. Component references can
4663 provide an additional array specification. */
4666 find_array_spec (gfc_expr
*e
)
4672 if (e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
4673 as
= CLASS_DATA (e
->symtree
->n
.sym
)->as
;
4675 as
= e
->symtree
->n
.sym
->as
;
4677 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4682 gfc_internal_error ("find_array_spec(): Missing spec");
4689 c
= ref
->u
.c
.component
;
4690 if (c
->attr
.dimension
)
4693 gfc_internal_error ("find_array_spec(): unused as(1)");
4704 gfc_internal_error ("find_array_spec(): unused as(2)");
4708 /* Resolve an array reference. */
4711 resolve_array_ref (gfc_array_ref
*ar
)
4713 int i
, check_scalar
;
4716 for (i
= 0; i
< ar
->dimen
+ ar
->codimen
; i
++)
4718 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
4720 /* Do not force gfc_index_integer_kind for the start. We can
4721 do fine with any integer kind. This avoids temporary arrays
4722 created for indexing with a vector. */
4723 if (gfc_resolve_index_1 (ar
->start
[i
], check_scalar
, 0) == FAILURE
)
4725 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
4727 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
4732 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
4736 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
4740 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
4741 if (e
->expr_type
== EXPR_VARIABLE
4742 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
4743 ar
->start
[i
] = gfc_get_parentheses (e
);
4747 gfc_error ("Array index at %L is an array of rank %d",
4748 &ar
->c_where
[i
], e
->rank
);
4752 /* Fill in the upper bound, which may be lower than the
4753 specified one for something like a(2:10:5), which is
4754 identical to a(2:7:5). Only relevant for strides not equal
4755 to one. Don't try a division by zero. */
4756 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4757 && ar
->stride
[i
] != NULL
&& ar
->stride
[i
]->expr_type
== EXPR_CONSTANT
4758 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 1L) != 0
4759 && mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0L) != 0)
4763 if (gfc_ref_dimen_size (ar
, i
, &size
, &end
) == SUCCESS
)
4765 if (ar
->end
[i
] == NULL
)
4768 gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
4770 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4772 else if (ar
->end
[i
]->ts
.type
== BT_INTEGER
4773 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
)
4775 mpz_set (ar
->end
[i
]->value
.integer
, end
);
4786 if (ar
->type
== AR_FULL
)
4788 if (ar
->as
->rank
== 0)
4789 ar
->type
= AR_ELEMENT
;
4791 /* Make sure array is the same as array(:,:), this way
4792 we don't need to special case all the time. */
4793 ar
->dimen
= ar
->as
->rank
;
4794 for (i
= 0; i
< ar
->dimen
; i
++)
4796 ar
->dimen_type
[i
] = DIMEN_RANGE
;
4798 gcc_assert (ar
->start
[i
] == NULL
);
4799 gcc_assert (ar
->end
[i
] == NULL
);
4800 gcc_assert (ar
->stride
[i
] == NULL
);
4804 /* If the reference type is unknown, figure out what kind it is. */
4806 if (ar
->type
== AR_UNKNOWN
)
4808 ar
->type
= AR_ELEMENT
;
4809 for (i
= 0; i
< ar
->dimen
; i
++)
4810 if (ar
->dimen_type
[i
] == DIMEN_RANGE
4811 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
4813 ar
->type
= AR_SECTION
;
4818 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
4821 if (ar
->as
->corank
&& ar
->codimen
== 0)
4824 ar
->codimen
= ar
->as
->corank
;
4825 for (n
= ar
->dimen
; n
< ar
->dimen
+ ar
->codimen
; n
++)
4826 ar
->dimen_type
[n
] = DIMEN_THIS_IMAGE
;
4834 resolve_substring (gfc_ref
*ref
)
4836 int k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
4838 if (ref
->u
.ss
.start
!= NULL
)
4840 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
4843 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
4845 gfc_error ("Substring start index at %L must be of type INTEGER",
4846 &ref
->u
.ss
.start
->where
);
4850 if (ref
->u
.ss
.start
->rank
!= 0)
4852 gfc_error ("Substring start index at %L must be scalar",
4853 &ref
->u
.ss
.start
->where
);
4857 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
4858 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4859 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4861 gfc_error ("Substring start index at %L is less than one",
4862 &ref
->u
.ss
.start
->where
);
4867 if (ref
->u
.ss
.end
!= NULL
)
4869 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
4872 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
4874 gfc_error ("Substring end index at %L must be of type INTEGER",
4875 &ref
->u
.ss
.end
->where
);
4879 if (ref
->u
.ss
.end
->rank
!= 0)
4881 gfc_error ("Substring end index at %L must be scalar",
4882 &ref
->u
.ss
.end
->where
);
4886 if (ref
->u
.ss
.length
!= NULL
4887 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
4888 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4889 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4891 gfc_error ("Substring end index at %L exceeds the string length",
4892 &ref
->u
.ss
.start
->where
);
4896 if (compare_bound_mpz_t (ref
->u
.ss
.end
,
4897 gfc_integer_kinds
[k
].huge
) == CMP_GT
4898 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
4899 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
4901 gfc_error ("Substring end index at %L is too large",
4902 &ref
->u
.ss
.end
->where
);
4911 /* This function supplies missing substring charlens. */
4914 gfc_resolve_substring_charlen (gfc_expr
*e
)
4917 gfc_expr
*start
, *end
;
4919 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
4920 if (char_ref
->type
== REF_SUBSTRING
)
4926 gcc_assert (char_ref
->next
== NULL
);
4930 if (e
->ts
.u
.cl
->length
)
4931 gfc_free_expr (e
->ts
.u
.cl
->length
);
4932 else if (e
->expr_type
== EXPR_VARIABLE
4933 && e
->symtree
->n
.sym
->attr
.dummy
)
4937 e
->ts
.type
= BT_CHARACTER
;
4938 e
->ts
.kind
= gfc_default_character_kind
;
4941 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
4943 if (char_ref
->u
.ss
.start
)
4944 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
4946 start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
4948 if (char_ref
->u
.ss
.end
)
4949 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
4950 else if (e
->expr_type
== EXPR_VARIABLE
)
4951 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
4958 /* Length = (end - start +1). */
4959 e
->ts
.u
.cl
->length
= gfc_subtract (end
, start
);
4960 e
->ts
.u
.cl
->length
= gfc_add (e
->ts
.u
.cl
->length
,
4961 gfc_get_int_expr (gfc_default_integer_kind
,
4964 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
4965 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
4967 /* Make sure that the length is simplified. */
4968 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 1);
4969 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
4973 /* Resolve subtype references. */
4976 resolve_ref (gfc_expr
*expr
)
4978 int current_part_dimension
, n_components
, seen_part_dimension
;
4981 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4982 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
4984 find_array_spec (expr
);
4988 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4992 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
5000 if (resolve_substring (ref
) == FAILURE
)
5005 /* Check constraints on part references. */
5007 current_part_dimension
= 0;
5008 seen_part_dimension
= 0;
5011 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5016 switch (ref
->u
.ar
.type
)
5019 /* Coarray scalar. */
5020 if (ref
->u
.ar
.as
->rank
== 0)
5022 current_part_dimension
= 0;
5027 current_part_dimension
= 1;
5031 current_part_dimension
= 0;
5035 gfc_internal_error ("resolve_ref(): Bad array reference");
5041 if (current_part_dimension
|| seen_part_dimension
)
5044 if (ref
->u
.c
.component
->attr
.pointer
5045 || ref
->u
.c
.component
->attr
.proc_pointer
5046 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5047 && CLASS_DATA (ref
->u
.c
.component
)->attr
.pointer
))
5049 gfc_error ("Component to the right of a part reference "
5050 "with nonzero rank must not have the POINTER "
5051 "attribute at %L", &expr
->where
);
5054 else if (ref
->u
.c
.component
->attr
.allocatable
5055 || (ref
->u
.c
.component
->ts
.type
== BT_CLASS
5056 && CLASS_DATA (ref
->u
.c
.component
)->attr
.allocatable
))
5059 gfc_error ("Component to the right of a part reference "
5060 "with nonzero rank must not have the ALLOCATABLE "
5061 "attribute at %L", &expr
->where
);
5073 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
5074 || ref
->next
== NULL
)
5075 && current_part_dimension
5076 && seen_part_dimension
)
5078 gfc_error ("Two or more part references with nonzero rank must "
5079 "not be specified at %L", &expr
->where
);
5083 if (ref
->type
== REF_COMPONENT
)
5085 if (current_part_dimension
)
5086 seen_part_dimension
= 1;
5088 /* reset to make sure */
5089 current_part_dimension
= 0;
5097 /* Given an expression, determine its shape. This is easier than it sounds.
5098 Leaves the shape array NULL if it is not possible to determine the shape. */
5101 expression_shape (gfc_expr
*e
)
5103 mpz_t array
[GFC_MAX_DIMENSIONS
];
5106 if (e
->rank
<= 0 || e
->shape
!= NULL
)
5109 for (i
= 0; i
< e
->rank
; i
++)
5110 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
5113 e
->shape
= gfc_get_shape (e
->rank
);
5115 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
5120 for (i
--; i
>= 0; i
--)
5121 mpz_clear (array
[i
]);
5125 /* Given a variable expression node, compute the rank of the expression by
5126 examining the base symbol and any reference structures it may have. */
5129 expression_rank (gfc_expr
*e
)
5134 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
5135 could lead to serious confusion... */
5136 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
5140 if (e
->expr_type
== EXPR_ARRAY
)
5142 /* Constructors can have a rank different from one via RESHAPE(). */
5144 if (e
->symtree
== NULL
)
5150 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
5151 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
5157 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5159 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.proc_pointer
5160 && ref
->u
.c
.component
->attr
.function
&& !ref
->next
)
5161 rank
= ref
->u
.c
.component
->as
? ref
->u
.c
.component
->as
->rank
: 0;
5163 if (ref
->type
!= REF_ARRAY
)
5166 if (ref
->u
.ar
.type
== AR_FULL
)
5168 rank
= ref
->u
.ar
.as
->rank
;
5172 if (ref
->u
.ar
.type
== AR_SECTION
)
5174 /* Figure out the rank of the section. */
5176 gfc_internal_error ("expression_rank(): Two array specs");
5178 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5179 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
5180 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
5190 expression_shape (e
);
5194 /* Resolve a variable expression. */
5197 resolve_variable (gfc_expr
*e
)
5204 if (e
->symtree
== NULL
)
5206 sym
= e
->symtree
->n
.sym
;
5208 /* TS 29113, 407b. */
5209 if (e
->ts
.type
== BT_ASSUMED
)
5213 gfc_error ("Assumed-type variable %s at %L may only be used "
5214 "as actual argument", sym
->name
, &e
->where
);
5217 else if (inquiry_argument
&& !first_actual_arg
)
5219 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5220 for all inquiry functions in resolve_function; the reason is
5221 that the function-name resolution happens too late in that
5223 gfc_error ("Assumed-type variable %s at %L as actual argument to "
5224 "an inquiry function shall be the first argument",
5225 sym
->name
, &e
->where
);
5230 /* TS 29113, C535b. */
5231 if ((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5232 && CLASS_DATA (sym
)->as
5233 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5234 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5235 && sym
->as
->type
== AS_ASSUMED_RANK
))
5239 gfc_error ("Assumed-rank variable %s at %L may only be used as "
5240 "actual argument", sym
->name
, &e
->where
);
5243 else if (inquiry_argument
&& !first_actual_arg
)
5245 /* FIXME: It doesn't work reliably as inquiry_argument is not set
5246 for all inquiry functions in resolve_function; the reason is
5247 that the function-name resolution happens too late in that
5249 gfc_error ("Assumed-rank variable %s at %L as actual argument "
5250 "to an inquiry function shall be the first argument",
5251 sym
->name
, &e
->where
);
5256 /* TS 29113, 407b. */
5257 if (e
->ts
.type
== BT_ASSUMED
&& e
->ref
5258 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5259 && e
->ref
->next
== NULL
))
5261 gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
5262 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5266 /* TS 29113, C535b. */
5267 if (((sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
5268 && CLASS_DATA (sym
)->as
5269 && CLASS_DATA (sym
)->as
->type
== AS_ASSUMED_RANK
)
5270 || (sym
->ts
.type
!= BT_CLASS
&& sym
->as
5271 && sym
->as
->type
== AS_ASSUMED_RANK
))
5273 && !(e
->ref
->type
== REF_ARRAY
&& e
->ref
->u
.ar
.type
== AR_FULL
5274 && e
->ref
->next
== NULL
))
5276 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
5277 "reference", sym
->name
, &e
->ref
->u
.ar
.where
);
5282 /* If this is an associate-name, it may be parsed with an array reference
5283 in error even though the target is scalar. Fail directly in this case.
5284 TODO Understand why class scalar expressions must be excluded. */
5285 if (sym
->assoc
&& !(sym
->ts
.type
== BT_CLASS
&& e
->rank
== 0))
5287 if (sym
->ts
.type
== BT_CLASS
)
5288 gfc_fix_class_refs (e
);
5289 if (!sym
->attr
.dimension
&& e
->ref
&& e
->ref
->type
== REF_ARRAY
)
5293 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.generic
)
5294 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
5296 /* On the other hand, the parser may not have known this is an array;
5297 in this case, we have to add a FULL reference. */
5298 if (sym
->assoc
&& sym
->attr
.dimension
&& !e
->ref
)
5300 e
->ref
= gfc_get_ref ();
5301 e
->ref
->type
= REF_ARRAY
;
5302 e
->ref
->u
.ar
.type
= AR_FULL
;
5303 e
->ref
->u
.ar
.dimen
= 0;
5306 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
5309 if (sym
->attr
.flavor
== FL_PROCEDURE
5310 && (!sym
->attr
.function
5311 || (sym
->attr
.function
&& sym
->result
5312 && sym
->result
->attr
.proc_pointer
5313 && !sym
->result
->attr
.function
)))
5315 e
->ts
.type
= BT_PROCEDURE
;
5316 goto resolve_procedure
;
5319 if (sym
->ts
.type
!= BT_UNKNOWN
)
5320 gfc_variable_attr (e
, &e
->ts
);
5323 /* Must be a simple variable reference. */
5324 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
5329 if (check_assumed_size_reference (sym
, e
))
5332 /* If a PRIVATE variable is used in the specification expression of the
5333 result variable, it might be accessed from outside the module and can
5334 thus not be TREE_PUBLIC() = 0.
5335 TODO: sym->attr.public_used only has to be set for the result variable's
5336 type-parameter expression and not for dummies or automatic variables.
5337 Additionally, it only has to be set if the function is either PUBLIC or
5338 used in a generic interface or TBP; unfortunately,
5339 proc_name->attr.public_used can get set at a later stage. */
5340 if (specification_expr
&& sym
->attr
.access
== ACCESS_PRIVATE
5341 && !sym
->attr
.function
&& !sym
->attr
.use_assoc
5342 && gfc_current_ns
->proc_name
&& gfc_current_ns
->proc_name
->attr
.function
)
5343 sym
->attr
.public_used
= 1;
5345 /* Deal with forward references to entries during resolve_code, to
5346 satisfy, at least partially, 12.5.2.5. */
5347 if (gfc_current_ns
->entries
5348 && current_entry_id
== sym
->entry_id
5351 && cs_base
->current
->op
!= EXEC_ENTRY
)
5353 gfc_entry_list
*entry
;
5354 gfc_formal_arglist
*formal
;
5358 /* If the symbol is a dummy... */
5359 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
5361 entry
= gfc_current_ns
->entries
;
5364 /* ...test if the symbol is a parameter of previous entries. */
5365 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
5366 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
5368 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
5372 /* If it has not been seen as a dummy, this is an error. */
5375 if (specification_expr
)
5376 gfc_error ("Variable '%s', used in a specification expression"
5377 ", is referenced at %L before the ENTRY statement "
5378 "in which it is a parameter",
5379 sym
->name
, &cs_base
->current
->loc
);
5381 gfc_error ("Variable '%s' is used at %L before the ENTRY "
5382 "statement in which it is a parameter",
5383 sym
->name
, &cs_base
->current
->loc
);
5388 /* Now do the same check on the specification expressions. */
5389 specification_expr
= 1;
5390 if (sym
->ts
.type
== BT_CHARACTER
5391 && gfc_resolve_expr (sym
->ts
.u
.cl
->length
) == FAILURE
)
5395 for (n
= 0; n
< sym
->as
->rank
; n
++)
5397 specification_expr
= 1;
5398 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
5400 specification_expr
= 1;
5401 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
5404 specification_expr
= 0;
5407 /* Update the symbol's entry level. */
5408 sym
->entry_id
= current_entry_id
+ 1;
5411 /* If a symbol has been host_associated mark it. This is used latter,
5412 to identify if aliasing is possible via host association. */
5413 if (sym
->attr
.flavor
== FL_VARIABLE
5414 && gfc_current_ns
->parent
5415 && (gfc_current_ns
->parent
== sym
->ns
5416 || (gfc_current_ns
->parent
->parent
5417 && gfc_current_ns
->parent
->parent
== sym
->ns
)))
5418 sym
->attr
.host_assoc
= 1;
5421 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
5424 /* F2008, C617 and C1229. */
5425 if (!inquiry_argument
&& (e
->ts
.type
== BT_CLASS
|| e
->ts
.type
== BT_DERIVED
)
5426 && gfc_is_coindexed (e
))
5428 gfc_ref
*ref
, *ref2
= NULL
;
5430 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5432 if (ref
->type
== REF_COMPONENT
)
5434 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.codimen
> 0)
5438 for ( ; ref
; ref
= ref
->next
)
5439 if (ref
->type
== REF_COMPONENT
)
5442 /* Expression itself is not coindexed object. */
5443 if (ref
&& e
->ts
.type
== BT_CLASS
)
5445 gfc_error ("Polymorphic subobject of coindexed object at %L",
5450 /* Expression itself is coindexed object. */
5454 c
= ref2
? ref2
->u
.c
.component
: e
->symtree
->n
.sym
->components
;
5455 for ( ; c
; c
= c
->next
)
5456 if (c
->attr
.allocatable
&& c
->ts
.type
== BT_CLASS
)
5458 gfc_error ("Coindexed object with polymorphic allocatable "
5459 "subcomponent at %L", &e
->where
);
5470 /* Checks to see that the correct symbol has been host associated.
5471 The only situation where this arises is that in which a twice
5472 contained function is parsed after the host association is made.
5473 Therefore, on detecting this, change the symbol in the expression
5474 and convert the array reference into an actual arglist if the old
5475 symbol is a variable. */
5477 check_host_association (gfc_expr
*e
)
5479 gfc_symbol
*sym
, *old_sym
;
5483 gfc_actual_arglist
*arg
, *tail
= NULL
;
5484 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
5486 /* If the expression is the result of substitution in
5487 interface.c(gfc_extend_expr) because there is no way in
5488 which the host association can be wrong. */
5489 if (e
->symtree
== NULL
5490 || e
->symtree
->n
.sym
== NULL
5491 || e
->user_operator
)
5494 old_sym
= e
->symtree
->n
.sym
;
5496 if (gfc_current_ns
->parent
5497 && old_sym
->ns
!= gfc_current_ns
)
5499 /* Use the 'USE' name so that renamed module symbols are
5500 correctly handled. */
5501 gfc_find_symbol (e
->symtree
->name
, gfc_current_ns
, 1, &sym
);
5503 if (sym
&& old_sym
!= sym
5504 && sym
->ts
.type
== old_sym
->ts
.type
5505 && sym
->attr
.flavor
== FL_PROCEDURE
5506 && sym
->attr
.contained
)
5508 /* Clear the shape, since it might not be valid. */
5509 gfc_free_shape (&e
->shape
, e
->rank
);
5511 /* Give the expression the right symtree! */
5512 gfc_find_sym_tree (e
->symtree
->name
, NULL
, 1, &st
);
5513 gcc_assert (st
!= NULL
);
5515 if (old_sym
->attr
.flavor
== FL_PROCEDURE
5516 || e
->expr_type
== EXPR_FUNCTION
)
5518 /* Original was function so point to the new symbol, since
5519 the actual argument list is already attached to the
5521 e
->value
.function
.esym
= NULL
;
5526 /* Original was variable so convert array references into
5527 an actual arglist. This does not need any checking now
5528 since resolve_function will take care of it. */
5529 e
->value
.function
.actual
= NULL
;
5530 e
->expr_type
= EXPR_FUNCTION
;
5533 /* Ambiguity will not arise if the array reference is not
5534 the last reference. */
5535 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5536 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5539 gcc_assert (ref
->type
== REF_ARRAY
);
5541 /* Grab the start expressions from the array ref and
5542 copy them into actual arguments. */
5543 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
5545 arg
= gfc_get_actual_arglist ();
5546 arg
->expr
= gfc_copy_expr (ref
->u
.ar
.start
[n
]);
5547 if (e
->value
.function
.actual
== NULL
)
5548 tail
= e
->value
.function
.actual
= arg
;
5556 /* Dump the reference list and set the rank. */
5557 gfc_free_ref_list (e
->ref
);
5559 e
->rank
= sym
->as
? sym
->as
->rank
: 0;
5562 gfc_resolve_expr (e
);
5566 /* This might have changed! */
5567 return e
->expr_type
== EXPR_FUNCTION
;
5572 gfc_resolve_character_operator (gfc_expr
*e
)
5574 gfc_expr
*op1
= e
->value
.op
.op1
;
5575 gfc_expr
*op2
= e
->value
.op
.op2
;
5576 gfc_expr
*e1
= NULL
;
5577 gfc_expr
*e2
= NULL
;
5579 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
5581 if (op1
->ts
.u
.cl
&& op1
->ts
.u
.cl
->length
)
5582 e1
= gfc_copy_expr (op1
->ts
.u
.cl
->length
);
5583 else if (op1
->expr_type
== EXPR_CONSTANT
)
5584 e1
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5585 op1
->value
.character
.length
);
5587 if (op2
->ts
.u
.cl
&& op2
->ts
.u
.cl
->length
)
5588 e2
= gfc_copy_expr (op2
->ts
.u
.cl
->length
);
5589 else if (op2
->expr_type
== EXPR_CONSTANT
)
5590 e2
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
5591 op2
->value
.character
.length
);
5593 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5603 e
->ts
.u
.cl
->length
= gfc_add (e1
, e2
);
5604 e
->ts
.u
.cl
->length
->ts
.type
= BT_INTEGER
;
5605 e
->ts
.u
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;
5606 gfc_simplify_expr (e
->ts
.u
.cl
->length
, 0);
5607 gfc_resolve_expr (e
->ts
.u
.cl
->length
);
5613 /* Ensure that an character expression has a charlen and, if possible, a
5614 length expression. */
5617 fixup_charlen (gfc_expr
*e
)
5619 /* The cases fall through so that changes in expression type and the need
5620 for multiple fixes are picked up. In all circumstances, a charlen should
5621 be available for the middle end to hang a backend_decl on. */
5622 switch (e
->expr_type
)
5625 gfc_resolve_character_operator (e
);
5628 if (e
->expr_type
== EXPR_ARRAY
)
5629 gfc_resolve_character_array_constructor (e
);
5631 case EXPR_SUBSTRING
:
5632 if (!e
->ts
.u
.cl
&& e
->ref
)
5633 gfc_resolve_substring_charlen (e
);
5637 e
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5644 /* Update an actual argument to include the passed-object for type-bound
5645 procedures at the right position. */
5647 static gfc_actual_arglist
*
5648 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
,
5651 gcc_assert (argpos
> 0);
5655 gfc_actual_arglist
* result
;
5657 result
= gfc_get_actual_arglist ();
5661 result
->name
= name
;
5667 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1, name
);
5669 lst
= update_arglist_pass (NULL
, po
, argpos
- 1, name
);
5674 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
5677 extract_compcall_passed_object (gfc_expr
* e
)
5681 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5683 if (e
->value
.compcall
.base_object
)
5684 po
= gfc_copy_expr (e
->value
.compcall
.base_object
);
5687 po
= gfc_get_expr ();
5688 po
->expr_type
= EXPR_VARIABLE
;
5689 po
->symtree
= e
->symtree
;
5690 po
->ref
= gfc_copy_ref (e
->ref
);
5691 po
->where
= e
->where
;
5694 if (gfc_resolve_expr (po
) == FAILURE
)
5701 /* Update the arglist of an EXPR_COMPCALL expression to include the
5705 update_compcall_arglist (gfc_expr
* e
)
5708 gfc_typebound_proc
* tbp
;
5710 tbp
= e
->value
.compcall
.tbp
;
5715 po
= extract_compcall_passed_object (e
);
5719 if (tbp
->nopass
|| e
->value
.compcall
.ignore_pass
)
5725 gcc_assert (tbp
->pass_arg_num
> 0);
5726 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5734 /* Extract the passed object from a PPC call (a copy of it). */
5737 extract_ppc_passed_object (gfc_expr
*e
)
5742 po
= gfc_get_expr ();
5743 po
->expr_type
= EXPR_VARIABLE
;
5744 po
->symtree
= e
->symtree
;
5745 po
->ref
= gfc_copy_ref (e
->ref
);
5746 po
->where
= e
->where
;
5748 /* Remove PPC reference. */
5750 while ((*ref
)->next
)
5751 ref
= &(*ref
)->next
;
5752 gfc_free_ref_list (*ref
);
5755 if (gfc_resolve_expr (po
) == FAILURE
)
5762 /* Update the actual arglist of a procedure pointer component to include the
5766 update_ppc_arglist (gfc_expr
* e
)
5770 gfc_typebound_proc
* tb
;
5772 ppc
= gfc_get_proc_ptr_comp (e
);
5780 else if (tb
->nopass
)
5783 po
= extract_ppc_passed_object (e
);
5790 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
5795 if (po
->ts
.type
== BT_DERIVED
&& po
->ts
.u
.derived
->attr
.abstract
)
5797 gfc_error ("Base object for procedure-pointer component call at %L is of"
5798 " ABSTRACT type '%s'", &e
->where
, po
->ts
.u
.derived
->name
);
5802 gcc_assert (tb
->pass_arg_num
> 0);
5803 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
5811 /* Check that the object a TBP is called on is valid, i.e. it must not be
5812 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
5815 check_typebound_baseobject (gfc_expr
* e
)
5818 gfc_try return_value
= FAILURE
;
5820 base
= extract_compcall_passed_object (e
);
5824 gcc_assert (base
->ts
.type
== BT_DERIVED
|| base
->ts
.type
== BT_CLASS
);
5826 if (base
->ts
.type
== BT_CLASS
&& !gfc_expr_attr (base
).class_ok
)
5830 if (base
->ts
.type
== BT_DERIVED
&& base
->ts
.u
.derived
->attr
.abstract
)
5832 gfc_error ("Base object for type-bound procedure call at %L is of"
5833 " ABSTRACT type '%s'", &e
->where
, base
->ts
.u
.derived
->name
);
5837 /* F08:C1230. If the procedure called is NOPASS,
5838 the base object must be scalar. */
5839 if (e
->value
.compcall
.tbp
->nopass
&& base
->rank
!= 0)
5841 gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
5842 " be scalar", &e
->where
);
5846 return_value
= SUCCESS
;
5849 gfc_free_expr (base
);
5850 return return_value
;
5854 /* Resolve a call to a type-bound procedure, either function or subroutine,
5855 statically from the data in an EXPR_COMPCALL expression. The adapted
5856 arglist and the target-procedure symtree are returned. */
5859 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
5860 gfc_actual_arglist
** actual
)
5862 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5863 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
5865 /* Update the actual arglist for PASS. */
5866 if (update_compcall_arglist (e
) == FAILURE
)
5869 *actual
= e
->value
.compcall
.actual
;
5870 *target
= e
->value
.compcall
.tbp
->u
.specific
;
5872 gfc_free_ref_list (e
->ref
);
5874 e
->value
.compcall
.actual
= NULL
;
5876 /* If we find a deferred typebound procedure, check for derived types
5877 that an overriding typebound procedure has not been missed. */
5878 if (e
->value
.compcall
.name
5879 && !e
->value
.compcall
.tbp
->non_overridable
5880 && e
->value
.compcall
.base_object
5881 && e
->value
.compcall
.base_object
->ts
.type
== BT_DERIVED
)
5884 gfc_symbol
*derived
;
5886 /* Use the derived type of the base_object. */
5887 derived
= e
->value
.compcall
.base_object
->ts
.u
.derived
;
5890 /* If necessary, go through the inheritance chain. */
5891 while (!st
&& derived
)
5893 /* Look for the typebound procedure 'name'. */
5894 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
5895 st
= gfc_find_symtree (derived
->f2k_derived
->tb_sym_root
,
5896 e
->value
.compcall
.name
);
5898 derived
= gfc_get_derived_super_type (derived
);
5901 /* Now find the specific name in the derived type namespace. */
5902 if (st
&& st
->n
.tb
&& st
->n
.tb
->u
.specific
)
5903 gfc_find_sym_tree (st
->n
.tb
->u
.specific
->name
,
5904 derived
->ns
, 1, &st
);
5912 /* Get the ultimate declared type from an expression. In addition,
5913 return the last class/derived type reference and the copy of the
5914 reference list. If check_types is set true, derived types are
5915 identified as well as class references. */
5917 get_declared_from_expr (gfc_ref
**class_ref
, gfc_ref
**new_ref
,
5918 gfc_expr
*e
, bool check_types
)
5920 gfc_symbol
*declared
;
5927 *new_ref
= gfc_copy_ref (e
->ref
);
5929 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5931 if (ref
->type
!= REF_COMPONENT
)
5934 if ((ref
->u
.c
.component
->ts
.type
== BT_CLASS
5935 || (check_types
&& ref
->u
.c
.component
->ts
.type
== BT_DERIVED
))
5936 && ref
->u
.c
.component
->attr
.flavor
!= FL_PROCEDURE
)
5938 declared
= ref
->u
.c
.component
->ts
.u
.derived
;
5944 if (declared
== NULL
)
5945 declared
= e
->symtree
->n
.sym
->ts
.u
.derived
;
5951 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
5952 which of the specific bindings (if any) matches the arglist and transform
5953 the expression into a call of that binding. */
5956 resolve_typebound_generic_call (gfc_expr
* e
, const char **name
)
5958 gfc_typebound_proc
* genproc
;
5959 const char* genname
;
5961 gfc_symbol
*derived
;
5963 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
5964 genname
= e
->value
.compcall
.name
;
5965 genproc
= e
->value
.compcall
.tbp
;
5967 if (!genproc
->is_generic
)
5970 /* Try the bindings on this type and in the inheritance hierarchy. */
5971 for (; genproc
; genproc
= genproc
->overridden
)
5975 gcc_assert (genproc
->is_generic
);
5976 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
5979 gfc_actual_arglist
* args
;
5982 gcc_assert (g
->specific
);
5984 if (g
->specific
->error
)
5987 target
= g
->specific
->u
.specific
->n
.sym
;
5989 /* Get the right arglist by handling PASS/NOPASS. */
5990 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
5991 if (!g
->specific
->nopass
)
5994 po
= extract_compcall_passed_object (e
);
5998 gcc_assert (g
->specific
->pass_arg_num
> 0);
5999 gcc_assert (!g
->specific
->error
);
6000 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
,
6001 g
->specific
->pass_arg
);
6003 resolve_actual_arglist (args
, target
->attr
.proc
,
6004 is_external_proc (target
) && !target
->formal
);
6006 /* Check if this arglist matches the formal. */
6007 matches
= gfc_arglist_matches_symbol (&args
, target
);
6009 /* Clean up and break out of the loop if we've found it. */
6010 gfc_free_actual_arglist (args
);
6013 e
->value
.compcall
.tbp
= g
->specific
;
6014 genname
= g
->specific_st
->name
;
6015 /* Pass along the name for CLASS methods, where the vtab
6016 procedure pointer component has to be referenced. */
6024 /* Nothing matching found! */
6025 gfc_error ("Found no matching specific binding for the call to the GENERIC"
6026 " '%s' at %L", genname
, &e
->where
);
6030 /* Make sure that we have the right specific instance for the name. */
6031 derived
= get_declared_from_expr (NULL
, NULL
, e
, true);
6033 st
= gfc_find_typebound_proc (derived
, NULL
, genname
, true, &e
->where
);
6035 e
->value
.compcall
.tbp
= st
->n
.tb
;
6041 /* Resolve a call to a type-bound subroutine. */
6044 resolve_typebound_call (gfc_code
* c
, const char **name
)
6046 gfc_actual_arglist
* newactual
;
6047 gfc_symtree
* target
;
6049 /* Check that's really a SUBROUTINE. */
6050 if (!c
->expr1
->value
.compcall
.tbp
->subroutine
)
6052 gfc_error ("'%s' at %L should be a SUBROUTINE",
6053 c
->expr1
->value
.compcall
.name
, &c
->loc
);
6057 if (check_typebound_baseobject (c
->expr1
) == FAILURE
)
6060 /* Pass along the name for CLASS methods, where the vtab
6061 procedure pointer component has to be referenced. */
6063 *name
= c
->expr1
->value
.compcall
.name
;
6065 if (resolve_typebound_generic_call (c
->expr1
, name
) == FAILURE
)
6068 /* Transform into an ordinary EXEC_CALL for now. */
6070 if (resolve_typebound_static (c
->expr1
, &target
, &newactual
) == FAILURE
)
6073 c
->ext
.actual
= newactual
;
6074 c
->symtree
= target
;
6075 c
->op
= (c
->expr1
->value
.compcall
.assign
? EXEC_ASSIGN_CALL
: EXEC_CALL
);
6077 gcc_assert (!c
->expr1
->ref
&& !c
->expr1
->value
.compcall
.actual
);
6079 gfc_free_expr (c
->expr1
);
6080 c
->expr1
= gfc_get_expr ();
6081 c
->expr1
->expr_type
= EXPR_FUNCTION
;
6082 c
->expr1
->symtree
= target
;
6083 c
->expr1
->where
= c
->loc
;
6085 return resolve_call (c
);
6089 /* Resolve a component-call expression. */
6091 resolve_compcall (gfc_expr
* e
, const char **name
)
6093 gfc_actual_arglist
* newactual
;
6094 gfc_symtree
* target
;
6096 /* Check that's really a FUNCTION. */
6097 if (!e
->value
.compcall
.tbp
->function
)
6099 gfc_error ("'%s' at %L should be a FUNCTION",
6100 e
->value
.compcall
.name
, &e
->where
);
6104 /* These must not be assign-calls! */
6105 gcc_assert (!e
->value
.compcall
.assign
);
6107 if (check_typebound_baseobject (e
) == FAILURE
)
6110 /* Pass along the name for CLASS methods, where the vtab
6111 procedure pointer component has to be referenced. */
6113 *name
= e
->value
.compcall
.name
;
6115 if (resolve_typebound_generic_call (e
, name
) == FAILURE
)
6117 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
6119 /* Take the rank from the function's symbol. */
6120 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
6121 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
6123 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
6124 arglist to the TBP's binding target. */
6126 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
6129 e
->value
.function
.actual
= newactual
;
6130 e
->value
.function
.name
= NULL
;
6131 e
->value
.function
.esym
= target
->n
.sym
;
6132 e
->value
.function
.isym
= NULL
;
6133 e
->symtree
= target
;
6134 e
->ts
= target
->n
.sym
->ts
;
6135 e
->expr_type
= EXPR_FUNCTION
;
6137 /* Resolution is not necessary if this is a class subroutine; this
6138 function only has to identify the specific proc. Resolution of
6139 the call will be done next in resolve_typebound_call. */
6140 return gfc_resolve_expr (e
);
6145 /* Resolve a typebound function, or 'method'. First separate all
6146 the non-CLASS references by calling resolve_compcall directly. */
6149 resolve_typebound_function (gfc_expr
* e
)
6151 gfc_symbol
*declared
;
6163 /* Deal with typebound operators for CLASS objects. */
6164 expr
= e
->value
.compcall
.base_object
;
6165 overridable
= !e
->value
.compcall
.tbp
->non_overridable
;
6166 if (expr
&& expr
->ts
.type
== BT_CLASS
&& e
->value
.compcall
.name
)
6168 /* If the base_object is not a variable, the corresponding actual
6169 argument expression must be stored in e->base_expression so
6170 that the corresponding tree temporary can be used as the base
6171 object in gfc_conv_procedure_call. */
6172 if (expr
->expr_type
!= EXPR_VARIABLE
)
6174 gfc_actual_arglist
*args
;
6176 for (args
= e
->value
.function
.actual
; args
; args
= args
->next
)
6178 if (expr
== args
->expr
)
6183 /* Since the typebound operators are generic, we have to ensure
6184 that any delays in resolution are corrected and that the vtab
6187 declared
= ts
.u
.derived
;
6188 c
= gfc_find_component (declared
, "_vptr", true, true);
6189 if (c
->ts
.u
.derived
== NULL
)
6190 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6192 if (resolve_compcall (e
, &name
) == FAILURE
)
6195 /* Use the generic name if it is there. */
6196 name
= name
? name
: e
->value
.function
.esym
->name
;
6197 e
->symtree
= expr
->symtree
;
6198 e
->ref
= gfc_copy_ref (expr
->ref
);
6199 get_declared_from_expr (&class_ref
, NULL
, e
, false);
6201 /* Trim away the extraneous references that emerge from nested
6202 use of interface.c (extend_expr). */
6203 if (class_ref
&& class_ref
->next
)
6205 gfc_free_ref_list (class_ref
->next
);
6206 class_ref
->next
= NULL
;
6208 else if (e
->ref
&& !class_ref
)
6210 gfc_free_ref_list (e
->ref
);
6214 gfc_add_vptr_component (e
);
6215 gfc_add_component_ref (e
, name
);
6216 e
->value
.function
.esym
= NULL
;
6217 if (expr
->expr_type
!= EXPR_VARIABLE
)
6218 e
->base_expr
= expr
;
6223 return resolve_compcall (e
, NULL
);
6225 if (resolve_ref (e
) == FAILURE
)
6228 /* Get the CLASS declared type. */
6229 declared
= get_declared_from_expr (&class_ref
, &new_ref
, e
, true);
6231 /* Weed out cases of the ultimate component being a derived type. */
6232 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6233 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6235 gfc_free_ref_list (new_ref
);
6236 return resolve_compcall (e
, NULL
);
6239 c
= gfc_find_component (declared
, "_data", true, true);
6240 declared
= c
->ts
.u
.derived
;
6242 /* Treat the call as if it is a typebound procedure, in order to roll
6243 out the correct name for the specific function. */
6244 if (resolve_compcall (e
, &name
) == FAILURE
)
6250 /* Convert the expression to a procedure pointer component call. */
6251 e
->value
.function
.esym
= NULL
;
6257 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6258 gfc_add_vptr_component (e
);
6259 gfc_add_component_ref (e
, name
);
6261 /* Recover the typespec for the expression. This is really only
6262 necessary for generic procedures, where the additional call
6263 to gfc_add_component_ref seems to throw the collection of the
6264 correct typespec. */
6271 /* Resolve a typebound subroutine, or 'method'. First separate all
6272 the non-CLASS references by calling resolve_typebound_call
6276 resolve_typebound_subroutine (gfc_code
*code
)
6278 gfc_symbol
*declared
;
6288 st
= code
->expr1
->symtree
;
6290 /* Deal with typebound operators for CLASS objects. */
6291 expr
= code
->expr1
->value
.compcall
.base_object
;
6292 overridable
= !code
->expr1
->value
.compcall
.tbp
->non_overridable
;
6293 if (expr
&& expr
->ts
.type
== BT_CLASS
&& code
->expr1
->value
.compcall
.name
)
6295 /* If the base_object is not a variable, the corresponding actual
6296 argument expression must be stored in e->base_expression so
6297 that the corresponding tree temporary can be used as the base
6298 object in gfc_conv_procedure_call. */
6299 if (expr
->expr_type
!= EXPR_VARIABLE
)
6301 gfc_actual_arglist
*args
;
6303 args
= code
->expr1
->value
.function
.actual
;
6304 for (; args
; args
= args
->next
)
6305 if (expr
== args
->expr
)
6309 /* Since the typebound operators are generic, we have to ensure
6310 that any delays in resolution are corrected and that the vtab
6312 declared
= expr
->ts
.u
.derived
;
6313 c
= gfc_find_component (declared
, "_vptr", true, true);
6314 if (c
->ts
.u
.derived
== NULL
)
6315 c
->ts
.u
.derived
= gfc_find_derived_vtab (declared
);
6317 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6320 /* Use the generic name if it is there. */
6321 name
= name
? name
: code
->expr1
->value
.function
.esym
->name
;
6322 code
->expr1
->symtree
= expr
->symtree
;
6323 code
->expr1
->ref
= gfc_copy_ref (expr
->ref
);
6325 /* Trim away the extraneous references that emerge from nested
6326 use of interface.c (extend_expr). */
6327 get_declared_from_expr (&class_ref
, NULL
, code
->expr1
, false);
6328 if (class_ref
&& class_ref
->next
)
6330 gfc_free_ref_list (class_ref
->next
);
6331 class_ref
->next
= NULL
;
6333 else if (code
->expr1
->ref
&& !class_ref
)
6335 gfc_free_ref_list (code
->expr1
->ref
);
6336 code
->expr1
->ref
= NULL
;
6339 /* Now use the procedure in the vtable. */
6340 gfc_add_vptr_component (code
->expr1
);
6341 gfc_add_component_ref (code
->expr1
, name
);
6342 code
->expr1
->value
.function
.esym
= NULL
;
6343 if (expr
->expr_type
!= EXPR_VARIABLE
)
6344 code
->expr1
->base_expr
= expr
;
6349 return resolve_typebound_call (code
, NULL
);
6351 if (resolve_ref (code
->expr1
) == FAILURE
)
6354 /* Get the CLASS declared type. */
6355 get_declared_from_expr (&class_ref
, &new_ref
, code
->expr1
, true);
6357 /* Weed out cases of the ultimate component being a derived type. */
6358 if ((class_ref
&& class_ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6359 || (!class_ref
&& st
->n
.sym
->ts
.type
!= BT_CLASS
))
6361 gfc_free_ref_list (new_ref
);
6362 return resolve_typebound_call (code
, NULL
);
6365 if (resolve_typebound_call (code
, &name
) == FAILURE
)
6367 ts
= code
->expr1
->ts
;
6371 /* Convert the expression to a procedure pointer component call. */
6372 code
->expr1
->value
.function
.esym
= NULL
;
6373 code
->expr1
->symtree
= st
;
6376 code
->expr1
->ref
= new_ref
;
6378 /* '_vptr' points to the vtab, which contains the procedure pointers. */
6379 gfc_add_vptr_component (code
->expr1
);
6380 gfc_add_component_ref (code
->expr1
, name
);
6382 /* Recover the typespec for the expression. This is really only
6383 necessary for generic procedures, where the additional call
6384 to gfc_add_component_ref seems to throw the collection of the
6385 correct typespec. */
6386 code
->expr1
->ts
= ts
;
6393 /* Resolve a CALL to a Procedure Pointer Component (Subroutine). */
6396 resolve_ppc_call (gfc_code
* c
)
6398 gfc_component
*comp
;
6400 comp
= gfc_get_proc_ptr_comp (c
->expr1
);
6401 gcc_assert (comp
!= NULL
);
6403 c
->resolved_sym
= c
->expr1
->symtree
->n
.sym
;
6404 c
->expr1
->expr_type
= EXPR_VARIABLE
;
6406 if (!comp
->attr
.subroutine
)
6407 gfc_add_subroutine (&comp
->attr
, comp
->name
, &c
->expr1
->where
);
6409 if (resolve_ref (c
->expr1
) == FAILURE
)
6412 if (update_ppc_arglist (c
->expr1
) == FAILURE
)
6415 c
->ext
.actual
= c
->expr1
->value
.compcall
.actual
;
6417 if (resolve_actual_arglist (c
->ext
.actual
, comp
->attr
.proc
,
6418 comp
->formal
== NULL
) == FAILURE
)
6421 gfc_ppc_use (comp
, &c
->expr1
->value
.compcall
.actual
, &c
->expr1
->where
);
6427 /* Resolve a Function Call to a Procedure Pointer Component (Function). */
6430 resolve_expr_ppc (gfc_expr
* e
)
6432 gfc_component
*comp
;
6434 comp
= gfc_get_proc_ptr_comp (e
);
6435 gcc_assert (comp
!= NULL
);
6437 /* Convert to EXPR_FUNCTION. */
6438 e
->expr_type
= EXPR_FUNCTION
;
6439 e
->value
.function
.isym
= NULL
;
6440 e
->value
.function
.actual
= e
->value
.compcall
.actual
;
6442 if (comp
->as
!= NULL
)
6443 e
->rank
= comp
->as
->rank
;
6445 if (!comp
->attr
.function
)
6446 gfc_add_function (&comp
->attr
, comp
->name
, &e
->where
);
6448 if (resolve_ref (e
) == FAILURE
)
6451 if (resolve_actual_arglist (e
->value
.function
.actual
, comp
->attr
.proc
,
6452 comp
->formal
== NULL
) == FAILURE
)
6455 if (update_ppc_arglist (e
) == FAILURE
)
6458 gfc_ppc_use (comp
, &e
->value
.compcall
.actual
, &e
->where
);
6465 gfc_is_expandable_expr (gfc_expr
*e
)
6467 gfc_constructor
*con
;
6469 if (e
->expr_type
== EXPR_ARRAY
)
6471 /* Traverse the constructor looking for variables that are flavor
6472 parameter. Parameters must be expanded since they are fully used at
6474 con
= gfc_constructor_first (e
->value
.constructor
);
6475 for (; con
; con
= gfc_constructor_next (con
))
6477 if (con
->expr
->expr_type
== EXPR_VARIABLE
6478 && con
->expr
->symtree
6479 && (con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
6480 || con
->expr
->symtree
->n
.sym
->attr
.flavor
== FL_VARIABLE
))
6482 if (con
->expr
->expr_type
== EXPR_ARRAY
6483 && gfc_is_expandable_expr (con
->expr
))
6491 /* Resolve an expression. That is, make sure that types of operands agree
6492 with their operators, intrinsic operators are converted to function calls
6493 for overloaded types and unresolved function references are resolved. */
6496 gfc_resolve_expr (gfc_expr
*e
)
6499 bool inquiry_save
, actual_arg_save
, first_actual_arg_save
;
6504 /* inquiry_argument only applies to variables. */
6505 inquiry_save
= inquiry_argument
;
6506 actual_arg_save
= actual_arg
;
6507 first_actual_arg_save
= first_actual_arg
;
6509 if (e
->expr_type
!= EXPR_VARIABLE
)
6511 inquiry_argument
= false;
6513 first_actual_arg
= false;
6516 switch (e
->expr_type
)
6519 t
= resolve_operator (e
);
6525 if (check_host_association (e
))
6526 t
= resolve_function (e
);
6529 t
= resolve_variable (e
);
6531 expression_rank (e
);
6534 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.u
.cl
== NULL
&& e
->ref
6535 && e
->ref
->type
!= REF_SUBSTRING
)
6536 gfc_resolve_substring_charlen (e
);
6541 t
= resolve_typebound_function (e
);
6544 case EXPR_SUBSTRING
:
6545 t
= resolve_ref (e
);
6554 t
= resolve_expr_ppc (e
);
6559 if (resolve_ref (e
) == FAILURE
)
6562 t
= gfc_resolve_array_constructor (e
);
6563 /* Also try to expand a constructor. */
6566 expression_rank (e
);
6567 if (gfc_is_constant_expr (e
) || gfc_is_expandable_expr (e
))
6568 gfc_expand_constructor (e
, false);
6571 /* This provides the opportunity for the length of constructors with
6572 character valued function elements to propagate the string length
6573 to the expression. */
6574 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
6576 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
6577 here rather then add a duplicate test for it above. */
6578 gfc_expand_constructor (e
, false);
6579 t
= gfc_resolve_character_array_constructor (e
);
6584 case EXPR_STRUCTURE
:
6585 t
= resolve_ref (e
);
6589 t
= resolve_structure_cons (e
, 0);
6593 t
= gfc_simplify_expr (e
, 0);
6597 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
6600 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.u
.cl
)
6603 inquiry_argument
= inquiry_save
;
6604 actual_arg
= actual_arg_save
;
6605 first_actual_arg
= first_actual_arg_save
;
6611 /* Resolve an expression from an iterator. They must be scalar and have
6612 INTEGER or (optionally) REAL type. */
6615 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
6616 const char *name_msgid
)
6618 if (gfc_resolve_expr (expr
) == FAILURE
)
6621 if (expr
->rank
!= 0)
6623 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
6627 if (expr
->ts
.type
!= BT_INTEGER
)
6629 if (expr
->ts
.type
== BT_REAL
)
6632 return gfc_notify_std (GFC_STD_F95_DEL
,
6633 "%s at %L must be integer",
6634 _(name_msgid
), &expr
->where
);
6637 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
6644 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
6652 /* Resolve the expressions in an iterator structure. If REAL_OK is
6653 false allow only INTEGER type iterators, otherwise allow REAL types. */
6656 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
6658 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
6662 if (gfc_check_vardef_context (iter
->var
, false, false, _("iterator variable"))
6666 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
6667 "Start expression in DO loop") == FAILURE
)
6670 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
6671 "End expression in DO loop") == FAILURE
)
6674 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
6675 "Step expression in DO loop") == FAILURE
)
6678 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
6680 if ((iter
->step
->ts
.type
== BT_INTEGER
6681 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
6682 || (iter
->step
->ts
.type
== BT_REAL
6683 && mpfr_sgn (iter
->step
->value
.real
) == 0))
6685 gfc_error ("Step expression in DO loop at %L cannot be zero",
6686 &iter
->step
->where
);
6691 /* Convert start, end, and step to the same type as var. */
6692 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
6693 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
6694 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
6696 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
6697 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
6698 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
6700 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
6701 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
6702 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
6704 if (iter
->start
->expr_type
== EXPR_CONSTANT
6705 && iter
->end
->expr_type
== EXPR_CONSTANT
6706 && iter
->step
->expr_type
== EXPR_CONSTANT
)
6709 if (iter
->start
->ts
.type
== BT_INTEGER
)
6711 sgn
= mpz_cmp_ui (iter
->step
->value
.integer
, 0);
6712 cmp
= mpz_cmp (iter
->end
->value
.integer
, iter
->start
->value
.integer
);
6716 sgn
= mpfr_sgn (iter
->step
->value
.real
);
6717 cmp
= mpfr_cmp (iter
->end
->value
.real
, iter
->start
->value
.real
);
6719 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
6720 gfc_warning ("DO loop at %L will be executed zero times",
6721 &iter
->step
->where
);
6728 /* Traversal function for find_forall_index. f == 2 signals that
6729 that variable itself is not to be checked - only the references. */
6732 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
6734 if (expr
->expr_type
!= EXPR_VARIABLE
)
6737 /* A scalar assignment */
6738 if (!expr
->ref
|| *f
== 1)
6740 if (expr
->symtree
->n
.sym
== sym
)
6752 /* Check whether the FORALL index appears in the expression or not.
6753 Returns SUCCESS if SYM is found in EXPR. */
6756 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
6758 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
6765 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
6766 to be a scalar INTEGER variable. The subscripts and stride are scalar
6767 INTEGERs, and if stride is a constant it must be nonzero.
6768 Furthermore "A subscript or stride in a forall-triplet-spec shall
6769 not contain a reference to any index-name in the
6770 forall-triplet-spec-list in which it appears." (7.5.4.1) */
6773 resolve_forall_iterators (gfc_forall_iterator
*it
)
6775 gfc_forall_iterator
*iter
, *iter2
;
6777 for (iter
= it
; iter
; iter
= iter
->next
)
6779 if (gfc_resolve_expr (iter
->var
) == SUCCESS
6780 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
6781 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
6784 if (gfc_resolve_expr (iter
->start
) == SUCCESS
6785 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
6786 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
6787 &iter
->start
->where
);
6788 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
6789 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 1);
6791 if (gfc_resolve_expr (iter
->end
) == SUCCESS
6792 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
6793 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
6795 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
6796 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 1);
6798 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
6800 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
6801 gfc_error ("FORALL stride expression at %L must be a scalar %s",
6802 &iter
->stride
->where
, "INTEGER");
6804 if (iter
->stride
->expr_type
== EXPR_CONSTANT
6805 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
6806 gfc_error ("FORALL stride expression at %L cannot be zero",
6807 &iter
->stride
->where
);
6809 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
6810 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 1);
6813 for (iter
= it
; iter
; iter
= iter
->next
)
6814 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
6816 if (find_forall_index (iter2
->start
,
6817 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6818 || find_forall_index (iter2
->end
,
6819 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
6820 || find_forall_index (iter2
->stride
,
6821 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
6822 gfc_error ("FORALL index '%s' may not appear in triplet "
6823 "specification at %L", iter
->var
->symtree
->name
,
6824 &iter2
->start
->where
);
6829 /* Given a pointer to a symbol that is a derived type, see if it's
6830 inaccessible, i.e. if it's defined in another module and the components are
6831 PRIVATE. The search is recursive if necessary. Returns zero if no
6832 inaccessible components are found, nonzero otherwise. */
6835 derived_inaccessible (gfc_symbol
*sym
)
6839 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
6842 for (c
= sym
->components
; c
; c
= c
->next
)
6844 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.u
.derived
))
6852 /* Resolve the argument of a deallocate expression. The expression must be
6853 a pointer or a full array. */
6856 resolve_deallocate_expr (gfc_expr
*e
)
6858 symbol_attribute attr
;
6859 int allocatable
, pointer
;
6864 if (gfc_resolve_expr (e
) == FAILURE
)
6867 if (e
->expr_type
!= EXPR_VARIABLE
)
6870 sym
= e
->symtree
->n
.sym
;
6872 if (sym
->ts
.type
== BT_CLASS
)
6874 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
6875 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
6879 allocatable
= sym
->attr
.allocatable
;
6880 pointer
= sym
->attr
.pointer
;
6882 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
6887 if (ref
->u
.ar
.type
!= AR_FULL
6888 && !(ref
->u
.ar
.type
== AR_ELEMENT
&& ref
->u
.ar
.as
->rank
== 0
6889 && ref
->u
.ar
.codimen
&& gfc_ref_this_image (ref
)))
6894 c
= ref
->u
.c
.component
;
6895 if (c
->ts
.type
== BT_CLASS
)
6897 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
6898 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
6902 allocatable
= c
->attr
.allocatable
;
6903 pointer
= c
->attr
.pointer
;
6913 attr
= gfc_expr_attr (e
);
6915 if (allocatable
== 0 && attr
.pointer
== 0)
6918 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
6924 if (gfc_is_coindexed (e
))
6926 gfc_error ("Coindexed allocatable object at %L", &e
->where
);
6931 && gfc_check_vardef_context (e
, true, true, _("DEALLOCATE object"))
6934 if (gfc_check_vardef_context (e
, false, true, _("DEALLOCATE object"))
6942 /* Returns true if the expression e contains a reference to the symbol sym. */
6944 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
6946 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
6953 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
6955 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
6959 /* Given the expression node e for an allocatable/pointer of derived type to be
6960 allocated, get the expression node to be initialized afterwards (needed for
6961 derived types with default initializers, and derived types with allocatable
6962 components that need nullification.) */
6965 gfc_expr_to_initialize (gfc_expr
*e
)
6971 result
= gfc_copy_expr (e
);
6973 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
6974 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
6975 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
6977 ref
->u
.ar
.type
= AR_FULL
;
6979 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
6980 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
6985 gfc_free_shape (&result
->shape
, result
->rank
);
6987 /* Recalculate rank, shape, etc. */
6988 gfc_resolve_expr (result
);
6993 /* If the last ref of an expression is an array ref, return a copy of the
6994 expression with that one removed. Otherwise, a copy of the original
6995 expression. This is used for allocate-expressions and pointer assignment
6996 LHS, where there may be an array specification that needs to be stripped
6997 off when using gfc_check_vardef_context. */
7000 remove_last_array_ref (gfc_expr
* e
)
7005 e2
= gfc_copy_expr (e
);
7006 for (r
= &e2
->ref
; *r
; r
= &(*r
)->next
)
7007 if ((*r
)->type
== REF_ARRAY
&& !(*r
)->next
)
7009 gfc_free_ref_list (*r
);
7018 /* Used in resolve_allocate_expr to check that a allocation-object and
7019 a source-expr are conformable. This does not catch all possible
7020 cases; in particular a runtime checking is needed. */
7023 conformable_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
7026 for (tail
= e2
->ref
; tail
&& tail
->next
; tail
= tail
->next
);
7028 /* First compare rank. */
7029 if (tail
&& e1
->rank
!= tail
->u
.ar
.as
->rank
)
7031 gfc_error ("Source-expr at %L must be scalar or have the "
7032 "same rank as the allocate-object at %L",
7033 &e1
->where
, &e2
->where
);
7044 for (i
= 0; i
< e1
->rank
; i
++)
7046 if (tail
->u
.ar
.end
[i
])
7048 mpz_set (s
, tail
->u
.ar
.end
[i
]->value
.integer
);
7049 mpz_sub (s
, s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7050 mpz_add_ui (s
, s
, 1);
7054 mpz_set (s
, tail
->u
.ar
.start
[i
]->value
.integer
);
7057 if (mpz_cmp (e1
->shape
[i
], s
) != 0)
7059 gfc_error ("Source-expr at %L and allocate-object at %L must "
7060 "have the same shape", &e1
->where
, &e2
->where
);
7073 /* Resolve the expression in an ALLOCATE statement, doing the additional
7074 checks to see whether the expression is OK or not. The expression must
7075 have a trailing array reference that gives the size of the array. */
7078 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
7080 int i
, pointer
, allocatable
, dimension
, is_abstract
;
7083 symbol_attribute attr
;
7084 gfc_ref
*ref
, *ref2
;
7087 gfc_symbol
*sym
= NULL
;
7092 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR
7093 checking of coarrays. */
7094 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
7095 if (ref
->next
== NULL
)
7098 if (ref
&& ref
->type
== REF_ARRAY
)
7099 ref
->u
.ar
.in_allocate
= true;
7101 if (gfc_resolve_expr (e
) == FAILURE
)
7104 /* Make sure the expression is allocatable or a pointer. If it is
7105 pointer, the next-to-last reference must be a pointer. */
7109 sym
= e
->symtree
->n
.sym
;
7111 /* Check whether ultimate component is abstract and CLASS. */
7114 if (e
->expr_type
!= EXPR_VARIABLE
)
7117 attr
= gfc_expr_attr (e
);
7118 pointer
= attr
.pointer
;
7119 dimension
= attr
.dimension
;
7120 codimension
= attr
.codimension
;
7124 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
7126 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
7127 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
7128 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
7129 codimension
= CLASS_DATA (sym
)->attr
.codimension
;
7130 is_abstract
= CLASS_DATA (sym
)->attr
.abstract
;
7134 allocatable
= sym
->attr
.allocatable
;
7135 pointer
= sym
->attr
.pointer
;
7136 dimension
= sym
->attr
.dimension
;
7137 codimension
= sym
->attr
.codimension
;
7142 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
7147 if (ref
->u
.ar
.codimen
> 0)
7150 for (n
= ref
->u
.ar
.dimen
;
7151 n
< ref
->u
.ar
.dimen
+ ref
->u
.ar
.codimen
; n
++)
7152 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_THIS_IMAGE
)
7159 if (ref
->next
!= NULL
)
7167 gfc_error ("Coindexed allocatable object at %L",
7172 c
= ref
->u
.c
.component
;
7173 if (c
->ts
.type
== BT_CLASS
)
7175 allocatable
= CLASS_DATA (c
)->attr
.allocatable
;
7176 pointer
= CLASS_DATA (c
)->attr
.class_pointer
;
7177 dimension
= CLASS_DATA (c
)->attr
.dimension
;
7178 codimension
= CLASS_DATA (c
)->attr
.codimension
;
7179 is_abstract
= CLASS_DATA (c
)->attr
.abstract
;
7183 allocatable
= c
->attr
.allocatable
;
7184 pointer
= c
->attr
.pointer
;
7185 dimension
= c
->attr
.dimension
;
7186 codimension
= c
->attr
.codimension
;
7187 is_abstract
= c
->attr
.abstract
;
7199 /* Check for F08:C628. */
7200 if (allocatable
== 0 && pointer
== 0)
7202 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
7207 /* Some checks for the SOURCE tag. */
7210 /* Check F03:C631. */
7211 if (!gfc_type_compatible (&e
->ts
, &code
->expr3
->ts
))
7213 gfc_error ("Type of entity at %L is type incompatible with "
7214 "source-expr at %L", &e
->where
, &code
->expr3
->where
);
7218 /* Check F03:C632 and restriction following Note 6.18. */
7219 if (code
->expr3
->rank
> 0
7220 && conformable_arrays (code
->expr3
, e
) == FAILURE
)
7223 /* Check F03:C633. */
7224 if (code
->expr3
->ts
.kind
!= e
->ts
.kind
)
7226 gfc_error ("The allocate-object at %L and the source-expr at %L "
7227 "shall have the same kind type parameter",
7228 &e
->where
, &code
->expr3
->where
);
7232 /* Check F2008, C642. */
7233 if (code
->expr3
->ts
.type
== BT_DERIVED
7234 && ((codimension
&& gfc_expr_attr (code
->expr3
).lock_comp
)
7235 || (code
->expr3
->ts
.u
.derived
->from_intmod
7236 == INTMOD_ISO_FORTRAN_ENV
7237 && code
->expr3
->ts
.u
.derived
->intmod_sym_id
7238 == ISOFORTRAN_LOCK_TYPE
)))
7240 gfc_error ("The source-expr at %L shall neither be of type "
7241 "LOCK_TYPE nor have a LOCK_TYPE component if "
7242 "allocate-object at %L is a coarray",
7243 &code
->expr3
->where
, &e
->where
);
7248 /* Check F08:C629. */
7249 if (is_abstract
&& code
->ext
.alloc
.ts
.type
== BT_UNKNOWN
7252 gcc_assert (e
->ts
.type
== BT_CLASS
);
7253 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
7254 "type-spec or source-expr", sym
->name
, &e
->where
);
7258 if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
&& !e
->ts
.deferred
)
7260 int cmp
= gfc_dep_compare_expr (e
->ts
.u
.cl
->length
,
7261 code
->ext
.alloc
.ts
.u
.cl
->length
);
7262 if (cmp
== 1 || cmp
== -1 || cmp
== -3)
7264 gfc_error ("Allocating %s at %L with type-spec requires the same "
7265 "character-length parameter as in the declaration",
7266 sym
->name
, &e
->where
);
7271 /* In the variable definition context checks, gfc_expr_attr is used
7272 on the expression. This is fooled by the array specification
7273 present in e, thus we have to eliminate that one temporarily. */
7274 e2
= remove_last_array_ref (e
);
7276 if (t
== SUCCESS
&& pointer
)
7277 t
= gfc_check_vardef_context (e2
, true, true, _("ALLOCATE object"));
7279 t
= gfc_check_vardef_context (e2
, false, true, _("ALLOCATE object"));
7284 if (e
->ts
.type
== BT_CLASS
&& CLASS_DATA (e
)->attr
.dimension
7285 && !code
->expr3
&& code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7287 /* For class arrays, the initialization with SOURCE is done
7288 using _copy and trans_call. It is convenient to exploit that
7289 when the allocated type is different from the declared type but
7290 no SOURCE exists by setting expr3. */
7291 code
->expr3
= gfc_default_initializer (&code
->ext
.alloc
.ts
);
7293 else if (!code
->expr3
)
7295 /* Set up default initializer if needed. */
7299 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7300 ts
= code
->ext
.alloc
.ts
;
7304 if (ts
.type
== BT_CLASS
)
7305 ts
= ts
.u
.derived
->components
->ts
;
7307 if (ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&ts
)))
7309 gfc_code
*init_st
= gfc_get_code ();
7310 init_st
->loc
= code
->loc
;
7311 init_st
->op
= EXEC_INIT_ASSIGN
;
7312 init_st
->expr1
= gfc_expr_to_initialize (e
);
7313 init_st
->expr2
= init_e
;
7314 init_st
->next
= code
->next
;
7315 code
->next
= init_st
;
7318 else if (code
->expr3
->mold
&& code
->expr3
->ts
.type
== BT_DERIVED
)
7320 /* Default initialization via MOLD (non-polymorphic). */
7321 gfc_expr
*rhs
= gfc_default_initializer (&code
->expr3
->ts
);
7322 gfc_resolve_expr (rhs
);
7323 gfc_free_expr (code
->expr3
);
7327 if (e
->ts
.type
== BT_CLASS
)
7329 /* Make sure the vtab symbol is present when
7330 the module variables are generated. */
7331 gfc_typespec ts
= e
->ts
;
7333 ts
= code
->expr3
->ts
;
7334 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
7335 ts
= code
->ext
.alloc
.ts
;
7336 gfc_find_derived_vtab (ts
.u
.derived
);
7338 e
= gfc_expr_to_initialize (e
);
7341 if (dimension
== 0 && codimension
== 0)
7344 /* Make sure the last reference node is an array specification. */
7346 if (!ref2
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
7347 || (dimension
&& ref2
->u
.ar
.dimen
== 0))
7349 gfc_error ("Array specification required in ALLOCATE statement "
7350 "at %L", &e
->where
);
7354 /* Make sure that the array section reference makes sense in the
7355 context of an ALLOCATE specification. */
7360 for (i
= ar
->dimen
; i
< ar
->dimen
+ ar
->codimen
; i
++)
7361 if (ar
->dimen_type
[i
] == DIMEN_THIS_IMAGE
)
7363 gfc_error ("Coarray specification required in ALLOCATE statement "
7364 "at %L", &e
->where
);
7368 for (i
= 0; i
< ar
->dimen
; i
++)
7370 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
7373 switch (ar
->dimen_type
[i
])
7379 if (ar
->start
[i
] != NULL
7380 && ar
->end
[i
] != NULL
7381 && ar
->stride
[i
] == NULL
)
7384 /* Fall Through... */
7389 case DIMEN_THIS_IMAGE
:
7390 gfc_error ("Bad array specification in ALLOCATE statement at %L",
7396 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7398 sym
= a
->expr
->symtree
->n
.sym
;
7400 /* TODO - check derived type components. */
7401 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
7404 if ((ar
->start
[i
] != NULL
7405 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
7406 || (ar
->end
[i
] != NULL
7407 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
7409 gfc_error ("'%s' must not appear in the array specification at "
7410 "%L in the same ALLOCATE statement where it is "
7411 "itself allocated", sym
->name
, &ar
->where
);
7417 for (i
= ar
->dimen
; i
< ar
->codimen
+ ar
->dimen
; i
++)
7419 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
7420 || ar
->dimen_type
[i
] == DIMEN_RANGE
)
7422 if (i
== (ar
->dimen
+ ar
->codimen
- 1))
7424 gfc_error ("Expected '*' in coindex specification in ALLOCATE "
7425 "statement at %L", &e
->where
);
7431 if (ar
->dimen_type
[i
] == DIMEN_STAR
&& i
== (ar
->dimen
+ ar
->codimen
- 1)
7432 && ar
->stride
[i
] == NULL
)
7435 gfc_error ("Bad coarray specification in ALLOCATE statement at %L",
7448 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
7450 gfc_expr
*stat
, *errmsg
, *pe
, *qe
;
7451 gfc_alloc
*a
, *p
, *q
;
7454 errmsg
= code
->expr2
;
7456 /* Check the stat variable. */
7459 gfc_check_vardef_context (stat
, false, false, _("STAT variable"));
7461 if ((stat
->ts
.type
!= BT_INTEGER
7462 && !(stat
->ref
&& (stat
->ref
->type
== REF_ARRAY
7463 || stat
->ref
->type
== REF_COMPONENT
)))
7465 gfc_error ("Stat-variable at %L must be a scalar INTEGER "
7466 "variable", &stat
->where
);
7468 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7469 if (p
->expr
->symtree
->n
.sym
->name
== stat
->symtree
->n
.sym
->name
)
7471 gfc_ref
*ref1
, *ref2
;
7474 for (ref1
= p
->expr
->ref
, ref2
= stat
->ref
; ref1
&& ref2
;
7475 ref1
= ref1
->next
, ref2
= ref2
->next
)
7477 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7479 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7488 gfc_error ("Stat-variable at %L shall not be %sd within "
7489 "the same %s statement", &stat
->where
, fcn
, fcn
);
7495 /* Check the errmsg variable. */
7499 gfc_warning ("ERRMSG at %L is useless without a STAT tag",
7502 gfc_check_vardef_context (errmsg
, false, false, _("ERRMSG variable"));
7504 if ((errmsg
->ts
.type
!= BT_CHARACTER
7506 && (errmsg
->ref
->type
== REF_ARRAY
7507 || errmsg
->ref
->type
== REF_COMPONENT
)))
7508 || errmsg
->rank
> 0 )
7509 gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
7510 "variable", &errmsg
->where
);
7512 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7513 if (p
->expr
->symtree
->n
.sym
->name
== errmsg
->symtree
->n
.sym
->name
)
7515 gfc_ref
*ref1
, *ref2
;
7518 for (ref1
= p
->expr
->ref
, ref2
= errmsg
->ref
; ref1
&& ref2
;
7519 ref1
= ref1
->next
, ref2
= ref2
->next
)
7521 if (ref1
->type
!= REF_COMPONENT
|| ref2
->type
!= REF_COMPONENT
)
7523 if (ref1
->u
.c
.component
->name
!= ref2
->u
.c
.component
->name
)
7532 gfc_error ("Errmsg-variable at %L shall not be %sd within "
7533 "the same %s statement", &errmsg
->where
, fcn
, fcn
);
7539 /* Check that an allocate-object appears only once in the statement. */
7541 for (p
= code
->ext
.alloc
.list
; p
; p
= p
->next
)
7544 for (q
= p
->next
; q
; q
= q
->next
)
7547 if (pe
->symtree
->n
.sym
->name
== qe
->symtree
->n
.sym
->name
)
7549 /* This is a potential collision. */
7550 gfc_ref
*pr
= pe
->ref
;
7551 gfc_ref
*qr
= qe
->ref
;
7553 /* Follow the references until
7554 a) They start to differ, in which case there is no error;
7555 you can deallocate a%b and a%c in a single statement
7556 b) Both of them stop, which is an error
7557 c) One of them stops, which is also an error. */
7560 if (pr
== NULL
&& qr
== NULL
)
7562 gfc_error ("Allocate-object at %L also appears at %L",
7563 &pe
->where
, &qe
->where
);
7566 else if (pr
!= NULL
&& qr
== NULL
)
7568 gfc_error ("Allocate-object at %L is subobject of"
7569 " object at %L", &pe
->where
, &qe
->where
);
7572 else if (pr
== NULL
&& qr
!= NULL
)
7574 gfc_error ("Allocate-object at %L is subobject of"
7575 " object at %L", &qe
->where
, &pe
->where
);
7578 /* Here, pr != NULL && qr != NULL */
7579 gcc_assert(pr
->type
== qr
->type
);
7580 if (pr
->type
== REF_ARRAY
)
7582 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
7584 gcc_assert (qr
->type
== REF_ARRAY
);
7586 if (pr
->next
&& qr
->next
)
7588 gfc_array_ref
*par
= &(pr
->u
.ar
);
7589 gfc_array_ref
*qar
= &(qr
->u
.ar
);
7590 if ((par
->start
[0] != NULL
|| qar
->start
[0] != NULL
)
7591 && gfc_dep_compare_expr (par
->start
[0],
7592 qar
->start
[0]) != 0)
7598 if (pr
->u
.c
.component
->name
!= qr
->u
.c
.component
->name
)
7609 if (strcmp (fcn
, "ALLOCATE") == 0)
7611 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7612 resolve_allocate_expr (a
->expr
, code
);
7616 for (a
= code
->ext
.alloc
.list
; a
; a
= a
->next
)
7617 resolve_deallocate_expr (a
->expr
);
7622 /************ SELECT CASE resolution subroutines ************/
7624 /* Callback function for our mergesort variant. Determines interval
7625 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
7626 op1 > op2. Assumes we're not dealing with the default case.
7627 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
7628 There are nine situations to check. */
7631 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
7635 if (op1
->low
== NULL
) /* op1 = (:L) */
7637 /* op2 = (:N), so overlap. */
7639 /* op2 = (M:) or (M:N), L < M */
7640 if (op2
->low
!= NULL
7641 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7644 else if (op1
->high
== NULL
) /* op1 = (K:) */
7646 /* op2 = (M:), so overlap. */
7648 /* op2 = (:N) or (M:N), K > N */
7649 if (op2
->high
!= NULL
7650 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7653 else /* op1 = (K:L) */
7655 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
7656 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7658 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
7659 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7661 else /* op2 = (M:N) */
7665 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
7668 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
7677 /* Merge-sort a double linked case list, detecting overlap in the
7678 process. LIST is the head of the double linked case list before it
7679 is sorted. Returns the head of the sorted list if we don't see any
7680 overlap, or NULL otherwise. */
7683 check_case_overlap (gfc_case
*list
)
7685 gfc_case
*p
, *q
, *e
, *tail
;
7686 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
7688 /* If the passed list was empty, return immediately. */
7695 /* Loop unconditionally. The only exit from this loop is a return
7696 statement, when we've finished sorting the case list. */
7703 /* Count the number of merges we do in this pass. */
7706 /* Loop while there exists a merge to be done. */
7711 /* Count this merge. */
7714 /* Cut the list in two pieces by stepping INSIZE places
7715 forward in the list, starting from P. */
7718 for (i
= 0; i
< insize
; i
++)
7727 /* Now we have two lists. Merge them! */
7728 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
7730 /* See from which the next case to merge comes from. */
7733 /* P is empty so the next case must come from Q. */
7738 else if (qsize
== 0 || q
== NULL
)
7747 cmp
= compare_cases (p
, q
);
7750 /* The whole case range for P is less than the
7758 /* The whole case range for Q is greater than
7759 the case range for P. */
7766 /* The cases overlap, or they are the same
7767 element in the list. Either way, we must
7768 issue an error and get the next case from P. */
7769 /* FIXME: Sort P and Q by line number. */
7770 gfc_error ("CASE label at %L overlaps with CASE "
7771 "label at %L", &p
->where
, &q
->where
);
7779 /* Add the next element to the merged list. */
7788 /* P has now stepped INSIZE places along, and so has Q. So
7789 they're the same. */
7794 /* If we have done only one merge or none at all, we've
7795 finished sorting the cases. */
7804 /* Otherwise repeat, merging lists twice the size. */
7810 /* Check to see if an expression is suitable for use in a CASE statement.
7811 Makes sure that all case expressions are scalar constants of the same
7812 type. Return FAILURE if anything is wrong. */
7815 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
7817 if (e
== NULL
) return SUCCESS
;
7819 if (e
->ts
.type
!= case_expr
->ts
.type
)
7821 gfc_error ("Expression in CASE statement at %L must be of type %s",
7822 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
7826 /* C805 (R808) For a given case-construct, each case-value shall be of
7827 the same type as case-expr. For character type, length differences
7828 are allowed, but the kind type parameters shall be the same. */
7830 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
7832 gfc_error ("Expression in CASE statement at %L must be of kind %d",
7833 &e
->where
, case_expr
->ts
.kind
);
7837 /* Convert the case value kind to that of case expression kind,
7840 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
7841 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
7845 gfc_error ("Expression in CASE statement at %L must be scalar",
7854 /* Given a completely parsed select statement, we:
7856 - Validate all expressions and code within the SELECT.
7857 - Make sure that the selection expression is not of the wrong type.
7858 - Make sure that no case ranges overlap.
7859 - Eliminate unreachable cases and unreachable code resulting from
7860 removing case labels.
7862 The standard does allow unreachable cases, e.g. CASE (5:3). But
7863 they are a hassle for code generation, and to prevent that, we just
7864 cut them out here. This is not necessary for overlapping cases
7865 because they are illegal and we never even try to generate code.
7867 We have the additional caveat that a SELECT construct could have
7868 been a computed GOTO in the source code. Fortunately we can fairly
7869 easily work around that here: The case_expr for a "real" SELECT CASE
7870 is in code->expr1, but for a computed GOTO it is in code->expr2. All
7871 we have to do is make sure that the case_expr is a scalar integer
7875 resolve_select (gfc_code
*code
)
7878 gfc_expr
*case_expr
;
7879 gfc_case
*cp
, *default_case
, *tail
, *head
;
7880 int seen_unreachable
;
7886 if (code
->expr1
== NULL
)
7888 /* This was actually a computed GOTO statement. */
7889 case_expr
= code
->expr2
;
7890 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
7891 gfc_error ("Selection expression in computed GOTO statement "
7892 "at %L must be a scalar integer expression",
7895 /* Further checking is not necessary because this SELECT was built
7896 by the compiler, so it should always be OK. Just move the
7897 case_expr from expr2 to expr so that we can handle computed
7898 GOTOs as normal SELECTs from here on. */
7899 code
->expr1
= code
->expr2
;
7904 case_expr
= code
->expr1
;
7906 type
= case_expr
->ts
.type
;
7907 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
7909 gfc_error ("Argument of SELECT statement at %L cannot be %s",
7910 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
7912 /* Punt. Going on here just produce more garbage error messages. */
7916 /* Raise a warning if an INTEGER case value exceeds the range of
7917 the case-expr. Later, all expressions will be promoted to the
7918 largest kind of all case-labels. */
7920 if (type
== BT_INTEGER
)
7921 for (body
= code
->block
; body
; body
= body
->block
)
7922 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7925 && gfc_check_integer_range (cp
->low
->value
.integer
,
7926 case_expr
->ts
.kind
) != ARITH_OK
)
7927 gfc_warning ("Expression in CASE statement at %L is "
7928 "not in the range of %s", &cp
->low
->where
,
7929 gfc_typename (&case_expr
->ts
));
7932 && cp
->low
!= cp
->high
7933 && gfc_check_integer_range (cp
->high
->value
.integer
,
7934 case_expr
->ts
.kind
) != ARITH_OK
)
7935 gfc_warning ("Expression in CASE statement at %L is "
7936 "not in the range of %s", &cp
->high
->where
,
7937 gfc_typename (&case_expr
->ts
));
7940 /* PR 19168 has a long discussion concerning a mismatch of the kinds
7941 of the SELECT CASE expression and its CASE values. Walk the lists
7942 of case values, and if we find a mismatch, promote case_expr to
7943 the appropriate kind. */
7945 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
7947 for (body
= code
->block
; body
; body
= body
->block
)
7949 /* Walk the case label list. */
7950 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7952 /* Intercept the DEFAULT case. It does not have a kind. */
7953 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7956 /* Unreachable case ranges are discarded, so ignore. */
7957 if (cp
->low
!= NULL
&& cp
->high
!= NULL
7958 && cp
->low
!= cp
->high
7959 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
7963 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
7964 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
7966 if (cp
->high
!= NULL
7967 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
7968 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
7973 /* Assume there is no DEFAULT case. */
7974 default_case
= NULL
;
7979 for (body
= code
->block
; body
; body
= body
->block
)
7981 /* Assume the CASE list is OK, and all CASE labels can be matched. */
7983 seen_unreachable
= 0;
7985 /* Walk the case label list, making sure that all case labels
7987 for (cp
= body
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
7989 /* Count the number of cases in the whole construct. */
7992 /* Intercept the DEFAULT case. */
7993 if (cp
->low
== NULL
&& cp
->high
== NULL
)
7995 if (default_case
!= NULL
)
7997 gfc_error ("The DEFAULT CASE at %L cannot be followed "
7998 "by a second DEFAULT CASE at %L",
7999 &default_case
->where
, &cp
->where
);
8010 /* Deal with single value cases and case ranges. Errors are
8011 issued from the validation function. */
8012 if (validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
8013 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
8019 if (type
== BT_LOGICAL
8020 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
8021 || cp
->low
!= cp
->high
))
8023 gfc_error ("Logical range in CASE statement at %L is not "
8024 "allowed", &cp
->low
->where
);
8029 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
8032 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
8033 if (value
& seen_logical
)
8035 gfc_error ("Constant logical value in CASE statement "
8036 "is repeated at %L",
8041 seen_logical
|= value
;
8044 if (cp
->low
!= NULL
&& cp
->high
!= NULL
8045 && cp
->low
!= cp
->high
8046 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
8048 if (gfc_option
.warn_surprising
)
8049 gfc_warning ("Range specification at %L can never "
8050 "be matched", &cp
->where
);
8052 cp
->unreachable
= 1;
8053 seen_unreachable
= 1;
8057 /* If the case range can be matched, it can also overlap with
8058 other cases. To make sure it does not, we put it in a
8059 double linked list here. We sort that with a merge sort
8060 later on to detect any overlapping cases. */
8064 head
->right
= head
->left
= NULL
;
8069 tail
->right
->left
= tail
;
8076 /* It there was a failure in the previous case label, give up
8077 for this case label list. Continue with the next block. */
8081 /* See if any case labels that are unreachable have been seen.
8082 If so, we eliminate them. This is a bit of a kludge because
8083 the case lists for a single case statement (label) is a
8084 single forward linked lists. */
8085 if (seen_unreachable
)
8087 /* Advance until the first case in the list is reachable. */
8088 while (body
->ext
.block
.case_list
!= NULL
8089 && body
->ext
.block
.case_list
->unreachable
)
8091 gfc_case
*n
= body
->ext
.block
.case_list
;
8092 body
->ext
.block
.case_list
= body
->ext
.block
.case_list
->next
;
8094 gfc_free_case_list (n
);
8097 /* Strip all other unreachable cases. */
8098 if (body
->ext
.block
.case_list
)
8100 for (cp
= body
->ext
.block
.case_list
; cp
->next
; cp
= cp
->next
)
8102 if (cp
->next
->unreachable
)
8104 gfc_case
*n
= cp
->next
;
8105 cp
->next
= cp
->next
->next
;
8107 gfc_free_case_list (n
);
8114 /* See if there were overlapping cases. If the check returns NULL,
8115 there was overlap. In that case we don't do anything. If head
8116 is non-NULL, we prepend the DEFAULT case. The sorted list can
8117 then used during code generation for SELECT CASE constructs with
8118 a case expression of a CHARACTER type. */
8121 head
= check_case_overlap (head
);
8123 /* Prepend the default_case if it is there. */
8124 if (head
!= NULL
&& default_case
)
8126 default_case
->left
= NULL
;
8127 default_case
->right
= head
;
8128 head
->left
= default_case
;
8132 /* Eliminate dead blocks that may be the result if we've seen
8133 unreachable case labels for a block. */
8134 for (body
= code
; body
&& body
->block
; body
= body
->block
)
8136 if (body
->block
->ext
.block
.case_list
== NULL
)
8138 /* Cut the unreachable block from the code chain. */
8139 gfc_code
*c
= body
->block
;
8140 body
->block
= c
->block
;
8142 /* Kill the dead block, but not the blocks below it. */
8144 gfc_free_statements (c
);
8148 /* More than two cases is legal but insane for logical selects.
8149 Issue a warning for it. */
8150 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
8152 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
8157 /* Check if a derived type is extensible. */
8160 gfc_type_is_extensible (gfc_symbol
*sym
)
8162 return !(sym
->attr
.is_bind_c
|| sym
->attr
.sequence
);
8166 /* Resolve an associate-name: Resolve target and ensure the type-spec is
8167 correct as well as possibly the array-spec. */
8170 resolve_assoc_var (gfc_symbol
* sym
, bool resolve_target
)
8174 gcc_assert (sym
->assoc
);
8175 gcc_assert (sym
->attr
.flavor
== FL_VARIABLE
);
8177 /* If this is for SELECT TYPE, the target may not yet be set. In that
8178 case, return. Resolution will be called later manually again when
8180 target
= sym
->assoc
->target
;
8183 gcc_assert (!sym
->assoc
->dangling
);
8185 if (resolve_target
&& gfc_resolve_expr (target
) != SUCCESS
)
8188 /* For variable targets, we get some attributes from the target. */
8189 if (target
->expr_type
== EXPR_VARIABLE
)
8193 gcc_assert (target
->symtree
);
8194 tsym
= target
->symtree
->n
.sym
;
8196 sym
->attr
.asynchronous
= tsym
->attr
.asynchronous
;
8197 sym
->attr
.volatile_
= tsym
->attr
.volatile_
;
8199 sym
->attr
.target
= tsym
->attr
.target
8200 || gfc_expr_attr (target
).pointer
;
8203 /* Get type if this was not already set. Note that it can be
8204 some other type than the target in case this is a SELECT TYPE
8205 selector! So we must not update when the type is already there. */
8206 if (sym
->ts
.type
== BT_UNKNOWN
)
8207 sym
->ts
= target
->ts
;
8208 gcc_assert (sym
->ts
.type
!= BT_UNKNOWN
);
8210 /* See if this is a valid association-to-variable. */
8211 sym
->assoc
->variable
= (target
->expr_type
== EXPR_VARIABLE
8212 && !gfc_has_vector_subscript (target
));
8214 /* Finally resolve if this is an array or not. */
8215 if (sym
->attr
.dimension
&& target
->rank
== 0)
8217 gfc_error ("Associate-name '%s' at %L is used as array",
8218 sym
->name
, &sym
->declared_at
);
8219 sym
->attr
.dimension
= 0;
8223 /* We cannot deal with class selectors that need temporaries. */
8224 if (target
->ts
.type
== BT_CLASS
8225 && gfc_ref_needs_temporary_p (target
->ref
))
8227 gfc_error ("CLASS selector at %L needs a temporary which is not "
8228 "yet implemented", &target
->where
);
8232 if (target
->ts
.type
!= BT_CLASS
&& target
->rank
> 0)
8233 sym
->attr
.dimension
= 1;
8234 else if (target
->ts
.type
== BT_CLASS
)
8235 gfc_fix_class_refs (target
);
8237 /* The associate-name will have a correct type by now. Make absolutely
8238 sure that it has not picked up a dimension attribute. */
8239 if (sym
->ts
.type
== BT_CLASS
)
8240 sym
->attr
.dimension
= 0;
8242 if (sym
->attr
.dimension
)
8244 sym
->as
= gfc_get_array_spec ();
8245 sym
->as
->rank
= target
->rank
;
8246 sym
->as
->type
= AS_DEFERRED
;
8248 /* Target must not be coindexed, thus the associate-variable
8250 sym
->as
->corank
= 0;
8255 /* Resolve a SELECT TYPE statement. */
8258 resolve_select_type (gfc_code
*code
, gfc_namespace
*old_ns
)
8260 gfc_symbol
*selector_type
;
8261 gfc_code
*body
, *new_st
, *if_st
, *tail
;
8262 gfc_code
*class_is
= NULL
, *default_case
= NULL
;
8265 char name
[GFC_MAX_SYMBOL_LEN
];
8269 ns
= code
->ext
.block
.ns
;
8272 /* Check for F03:C813. */
8273 if (code
->expr1
->ts
.type
!= BT_CLASS
8274 && !(code
->expr2
&& code
->expr2
->ts
.type
== BT_CLASS
))
8276 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
8277 "at %L", &code
->loc
);
8281 if (!code
->expr1
->symtree
->n
.sym
->attr
.class_ok
)
8286 if (code
->expr1
->symtree
->n
.sym
->attr
.untyped
)
8287 code
->expr1
->symtree
->n
.sym
->ts
= code
->expr2
->ts
;
8288 selector_type
= CLASS_DATA (code
->expr2
)->ts
.u
.derived
;
8291 selector_type
= CLASS_DATA (code
->expr1
)->ts
.u
.derived
;
8293 /* Loop over TYPE IS / CLASS IS cases. */
8294 for (body
= code
->block
; body
; body
= body
->block
)
8296 c
= body
->ext
.block
.case_list
;
8298 /* Check F03:C815. */
8299 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8300 && !gfc_type_is_extensible (c
->ts
.u
.derived
))
8302 gfc_error ("Derived type '%s' at %L must be extensible",
8303 c
->ts
.u
.derived
->name
, &c
->where
);
8308 /* Check F03:C816. */
8309 if ((c
->ts
.type
== BT_DERIVED
|| c
->ts
.type
== BT_CLASS
)
8310 && !gfc_type_is_extension_of (selector_type
, c
->ts
.u
.derived
))
8312 gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
8313 c
->ts
.u
.derived
->name
, &c
->where
, selector_type
->name
);
8318 /* Intercept the DEFAULT case. */
8319 if (c
->ts
.type
== BT_UNKNOWN
)
8321 /* Check F03:C818. */
8324 gfc_error ("The DEFAULT CASE at %L cannot be followed "
8325 "by a second DEFAULT CASE at %L",
8326 &default_case
->ext
.block
.case_list
->where
, &c
->where
);
8331 default_case
= body
;
8338 /* Transform SELECT TYPE statement to BLOCK and associate selector to
8339 target if present. If there are any EXIT statements referring to the
8340 SELECT TYPE construct, this is no problem because the gfc_code
8341 reference stays the same and EXIT is equally possible from the BLOCK
8342 it is changed to. */
8343 code
->op
= EXEC_BLOCK
;
8346 gfc_association_list
* assoc
;
8348 assoc
= gfc_get_association_list ();
8349 assoc
->st
= code
->expr1
->symtree
;
8350 assoc
->target
= gfc_copy_expr (code
->expr2
);
8351 assoc
->target
->where
= code
->expr2
->where
;
8352 /* assoc->variable will be set by resolve_assoc_var. */
8354 code
->ext
.block
.assoc
= assoc
;
8355 code
->expr1
->symtree
->n
.sym
->assoc
= assoc
;
8357 resolve_assoc_var (code
->expr1
->symtree
->n
.sym
, false);
8360 code
->ext
.block
.assoc
= NULL
;
8362 /* Add EXEC_SELECT to switch on type. */
8363 new_st
= gfc_get_code ();
8364 new_st
->op
= code
->op
;
8365 new_st
->expr1
= code
->expr1
;
8366 new_st
->expr2
= code
->expr2
;
8367 new_st
->block
= code
->block
;
8368 code
->expr1
= code
->expr2
= NULL
;
8373 ns
->code
->next
= new_st
;
8375 code
->op
= EXEC_SELECT
;
8376 gfc_add_vptr_component (code
->expr1
);
8377 gfc_add_hash_component (code
->expr1
);
8379 /* Loop over TYPE IS / CLASS IS cases. */
8380 for (body
= code
->block
; body
; body
= body
->block
)
8382 c
= body
->ext
.block
.case_list
;
8384 if (c
->ts
.type
== BT_DERIVED
)
8385 c
->low
= c
->high
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
,
8386 c
->ts
.u
.derived
->hash_value
);
8388 else if (c
->ts
.type
== BT_UNKNOWN
)
8391 /* Associate temporary to selector. This should only be done
8392 when this case is actually true, so build a new ASSOCIATE
8393 that does precisely this here (instead of using the
8396 if (c
->ts
.type
== BT_CLASS
)
8397 sprintf (name
, "__tmp_class_%s", c
->ts
.u
.derived
->name
);
8399 sprintf (name
, "__tmp_type_%s", c
->ts
.u
.derived
->name
);
8400 st
= gfc_find_symtree (ns
->sym_root
, name
);
8401 gcc_assert (st
->n
.sym
->assoc
);
8402 st
->n
.sym
->assoc
->target
= gfc_get_variable_expr (code
->expr1
->symtree
);
8403 st
->n
.sym
->assoc
->target
->where
= code
->expr1
->where
;
8404 if (c
->ts
.type
== BT_DERIVED
)
8405 gfc_add_data_component (st
->n
.sym
->assoc
->target
);
8407 new_st
= gfc_get_code ();
8408 new_st
->op
= EXEC_BLOCK
;
8409 new_st
->ext
.block
.ns
= gfc_build_block_ns (ns
);
8410 new_st
->ext
.block
.ns
->code
= body
->next
;
8411 body
->next
= new_st
;
8413 /* Chain in the new list only if it is marked as dangling. Otherwise
8414 there is a CASE label overlap and this is already used. Just ignore,
8415 the error is diagnosed elsewhere. */
8416 if (st
->n
.sym
->assoc
->dangling
)
8418 new_st
->ext
.block
.assoc
= st
->n
.sym
->assoc
;
8419 st
->n
.sym
->assoc
->dangling
= 0;
8422 resolve_assoc_var (st
->n
.sym
, false);
8425 /* Take out CLASS IS cases for separate treatment. */
8427 while (body
&& body
->block
)
8429 if (body
->block
->ext
.block
.case_list
->ts
.type
== BT_CLASS
)
8431 /* Add to class_is list. */
8432 if (class_is
== NULL
)
8434 class_is
= body
->block
;
8439 for (tail
= class_is
; tail
->block
; tail
= tail
->block
) ;
8440 tail
->block
= body
->block
;
8443 /* Remove from EXEC_SELECT list. */
8444 body
->block
= body
->block
->block
;
8457 /* Add a default case to hold the CLASS IS cases. */
8458 for (tail
= code
; tail
->block
; tail
= tail
->block
) ;
8459 tail
->block
= gfc_get_code ();
8461 tail
->op
= EXEC_SELECT_TYPE
;
8462 tail
->ext
.block
.case_list
= gfc_get_case ();
8463 tail
->ext
.block
.case_list
->ts
.type
= BT_UNKNOWN
;
8465 default_case
= tail
;
8468 /* More than one CLASS IS block? */
8469 if (class_is
->block
)
8473 /* Sort CLASS IS blocks by extension level. */
8477 for (c1
= &class_is
; (*c1
) && (*c1
)->block
; c1
= &((*c1
)->block
))
8480 /* F03:C817 (check for doubles). */
8481 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->hash_value
8482 == c2
->ext
.block
.case_list
->ts
.u
.derived
->hash_value
)
8484 gfc_error ("Double CLASS IS block in SELECT TYPE "
8486 &c2
->ext
.block
.case_list
->where
);
8489 if ((*c1
)->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
8490 < c2
->ext
.block
.case_list
->ts
.u
.derived
->attr
.extension
)
8493 (*c1
)->block
= c2
->block
;
8503 /* Generate IF chain. */
8504 if_st
= gfc_get_code ();
8505 if_st
->op
= EXEC_IF
;
8507 for (body
= class_is
; body
; body
= body
->block
)
8509 new_st
->block
= gfc_get_code ();
8510 new_st
= new_st
->block
;
8511 new_st
->op
= EXEC_IF
;
8512 /* Set up IF condition: Call _gfortran_is_extension_of. */
8513 new_st
->expr1
= gfc_get_expr ();
8514 new_st
->expr1
->expr_type
= EXPR_FUNCTION
;
8515 new_st
->expr1
->ts
.type
= BT_LOGICAL
;
8516 new_st
->expr1
->ts
.kind
= 4;
8517 new_st
->expr1
->value
.function
.name
= gfc_get_string (PREFIX ("is_extension_of"));
8518 new_st
->expr1
->value
.function
.isym
= XCNEW (gfc_intrinsic_sym
);
8519 new_st
->expr1
->value
.function
.isym
->id
= GFC_ISYM_EXTENDS_TYPE_OF
;
8520 /* Set up arguments. */
8521 new_st
->expr1
->value
.function
.actual
= gfc_get_actual_arglist ();
8522 new_st
->expr1
->value
.function
.actual
->expr
= gfc_get_variable_expr (code
->expr1
->symtree
);
8523 new_st
->expr1
->value
.function
.actual
->expr
->where
= code
->loc
;
8524 gfc_add_vptr_component (new_st
->expr1
->value
.function
.actual
->expr
);
8525 vtab
= gfc_find_derived_vtab (body
->ext
.block
.case_list
->ts
.u
.derived
);
8526 st
= gfc_find_symtree (vtab
->ns
->sym_root
, vtab
->name
);
8527 new_st
->expr1
->value
.function
.actual
->next
= gfc_get_actual_arglist ();
8528 new_st
->expr1
->value
.function
.actual
->next
->expr
= gfc_get_variable_expr (st
);
8529 new_st
->next
= body
->next
;
8531 if (default_case
->next
)
8533 new_st
->block
= gfc_get_code ();
8534 new_st
= new_st
->block
;
8535 new_st
->op
= EXEC_IF
;
8536 new_st
->next
= default_case
->next
;
8539 /* Replace CLASS DEFAULT code by the IF chain. */
8540 default_case
->next
= if_st
;
8543 /* Resolve the internal code. This can not be done earlier because
8544 it requires that the sym->assoc of selectors is set already. */
8545 gfc_current_ns
= ns
;
8546 gfc_resolve_blocks (code
->block
, gfc_current_ns
);
8547 gfc_current_ns
= old_ns
;
8549 resolve_select (code
);
8553 /* Resolve a transfer statement. This is making sure that:
8554 -- a derived type being transferred has only non-pointer components
8555 -- a derived type being transferred doesn't have private components, unless
8556 it's being transferred from the module where the type was defined
8557 -- we're not trying to transfer a whole assumed size array. */
8560 resolve_transfer (gfc_code
*code
)
8569 while (exp
!= NULL
&& exp
->expr_type
== EXPR_OP
8570 && exp
->value
.op
.op
== INTRINSIC_PARENTHESES
)
8571 exp
= exp
->value
.op
.op1
;
8573 if (exp
&& exp
->expr_type
== EXPR_NULL
&& exp
->ts
.type
== BT_UNKNOWN
)
8575 gfc_error ("NULL intrinsic at %L in data transfer statement requires "
8576 "MOLD=", &exp
->where
);
8580 if (exp
== NULL
|| (exp
->expr_type
!= EXPR_VARIABLE
8581 && exp
->expr_type
!= EXPR_FUNCTION
))
8584 /* If we are reading, the variable will be changed. Note that
8585 code->ext.dt may be NULL if the TRANSFER is related to
8586 an INQUIRE statement -- but in this case, we are not reading, either. */
8587 if (code
->ext
.dt
&& code
->ext
.dt
->dt_io_kind
->value
.iokind
== M_READ
8588 && gfc_check_vardef_context (exp
, false, false, _("item in READ"))
8592 sym
= exp
->symtree
->n
.sym
;
8595 /* Go to actual component transferred. */
8596 for (ref
= exp
->ref
; ref
; ref
= ref
->next
)
8597 if (ref
->type
== REF_COMPONENT
)
8598 ts
= &ref
->u
.c
.component
->ts
;
8600 if (ts
->type
== BT_CLASS
)
8602 /* FIXME: Test for defined input/output. */
8603 gfc_error ("Data transfer element at %L cannot be polymorphic unless "
8604 "it is processed by a defined input/output procedure",
8609 if (ts
->type
== BT_DERIVED
)
8611 /* Check that transferred derived type doesn't contain POINTER
8613 if (ts
->u
.derived
->attr
.pointer_comp
)
8615 gfc_error ("Data transfer element at %L cannot have POINTER "
8616 "components unless it is processed by a defined "
8617 "input/output procedure", &code
->loc
);
8622 if (ts
->u
.derived
->attr
.proc_pointer_comp
)
8624 gfc_error ("Data transfer element at %L cannot have "
8625 "procedure pointer components", &code
->loc
);
8629 if (ts
->u
.derived
->attr
.alloc_comp
)
8631 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
8632 "components unless it is processed by a defined "
8633 "input/output procedure", &code
->loc
);
8637 if (derived_inaccessible (ts
->u
.derived
))
8639 gfc_error ("Data transfer element at %L cannot have "
8640 "PRIVATE components",&code
->loc
);
8645 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
&& exp
->ref
8646 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
8648 gfc_error ("Data transfer element at %L cannot be a full reference to "
8649 "an assumed-size array", &code
->loc
);
8655 /*********** Toplevel code resolution subroutines ***********/
8657 /* Find the set of labels that are reachable from this block. We also
8658 record the last statement in each block. */
8661 find_reachable_labels (gfc_code
*block
)
8668 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
8670 /* Collect labels in this block. We don't keep those corresponding
8671 to END {IF|SELECT}, these are checked in resolve_branch by going
8672 up through the code_stack. */
8673 for (c
= block
; c
; c
= c
->next
)
8675 if (c
->here
&& c
->op
!= EXEC_END_NESTED_BLOCK
)
8676 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
8679 /* Merge with labels from parent block. */
8682 gcc_assert (cs_base
->prev
->reachable_labels
);
8683 bitmap_ior_into (cs_base
->reachable_labels
,
8684 cs_base
->prev
->reachable_labels
);
8690 resolve_lock_unlock (gfc_code
*code
)
8692 if (code
->expr1
->ts
.type
!= BT_DERIVED
8693 || code
->expr1
->expr_type
!= EXPR_VARIABLE
8694 || code
->expr1
->ts
.u
.derived
->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
8695 || code
->expr1
->ts
.u
.derived
->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE
8696 || code
->expr1
->rank
!= 0
8697 || (!gfc_is_coarray (code
->expr1
) && !gfc_is_coindexed (code
->expr1
)))
8698 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
8699 &code
->expr1
->where
);
8703 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8704 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8705 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8706 &code
->expr2
->where
);
8709 && gfc_check_vardef_context (code
->expr2
, false, false,
8710 _("STAT variable")) == FAILURE
)
8715 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8716 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8717 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8718 &code
->expr3
->where
);
8721 && gfc_check_vardef_context (code
->expr3
, false, false,
8722 _("ERRMSG variable")) == FAILURE
)
8725 /* Check ACQUIRED_LOCK. */
8727 && (code
->expr4
->ts
.type
!= BT_LOGICAL
|| code
->expr4
->rank
!= 0
8728 || code
->expr4
->expr_type
!= EXPR_VARIABLE
))
8729 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
8730 "variable", &code
->expr4
->where
);
8733 && gfc_check_vardef_context (code
->expr4
, false, false,
8734 _("ACQUIRED_LOCK variable")) == FAILURE
)
8740 resolve_sync (gfc_code
*code
)
8742 /* Check imageset. The * case matches expr1 == NULL. */
8745 if (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
> 1)
8746 gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
8747 "INTEGER expression", &code
->expr1
->where
);
8748 if (code
->expr1
->expr_type
== EXPR_CONSTANT
&& code
->expr1
->rank
== 0
8749 && mpz_cmp_si (code
->expr1
->value
.integer
, 1) < 0)
8750 gfc_error ("Imageset argument at %L must between 1 and num_images()",
8751 &code
->expr1
->where
);
8752 else if (code
->expr1
->expr_type
== EXPR_ARRAY
8753 && gfc_simplify_expr (code
->expr1
, 0) == SUCCESS
)
8755 gfc_constructor
*cons
;
8756 cons
= gfc_constructor_first (code
->expr1
->value
.constructor
);
8757 for (; cons
; cons
= gfc_constructor_next (cons
))
8758 if (cons
->expr
->expr_type
== EXPR_CONSTANT
8759 && mpz_cmp_si (cons
->expr
->value
.integer
, 1) < 0)
8760 gfc_error ("Imageset argument at %L must between 1 and "
8761 "num_images()", &cons
->expr
->where
);
8767 && (code
->expr2
->ts
.type
!= BT_INTEGER
|| code
->expr2
->rank
!= 0
8768 || code
->expr2
->expr_type
!= EXPR_VARIABLE
))
8769 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
8770 &code
->expr2
->where
);
8774 && (code
->expr3
->ts
.type
!= BT_CHARACTER
|| code
->expr3
->rank
!= 0
8775 || code
->expr3
->expr_type
!= EXPR_VARIABLE
))
8776 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
8777 &code
->expr3
->where
);
8781 /* Given a branch to a label, see if the branch is conforming.
8782 The code node describes where the branch is located. */
8785 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
8792 /* Step one: is this a valid branching target? */
8794 if (label
->defined
== ST_LABEL_UNKNOWN
)
8796 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
8801 if (label
->defined
!= ST_LABEL_TARGET
&& label
->defined
!= ST_LABEL_DO_TARGET
)
8803 gfc_error ("Statement at %L is not a valid branch target statement "
8804 "for the branch statement at %L", &label
->where
, &code
->loc
);
8808 /* Step two: make sure this branch is not a branch to itself ;-) */
8810 if (code
->here
== label
)
8812 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
8816 /* Step three: See if the label is in the same block as the
8817 branching statement. The hard work has been done by setting up
8818 the bitmap reachable_labels. */
8820 if (bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
8822 /* Check now whether there is a CRITICAL construct; if so, check
8823 whether the label is still visible outside of the CRITICAL block,
8824 which is invalid. */
8825 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8827 if (stack
->current
->op
== EXEC_CRITICAL
8828 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8829 gfc_error ("GOTO statement at %L leaves CRITICAL construct for "
8830 "label at %L", &code
->loc
, &label
->where
);
8831 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
8832 && bitmap_bit_p (stack
->reachable_labels
, label
->value
))
8833 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct "
8834 "for label at %L", &code
->loc
, &label
->where
);
8840 /* Step four: If we haven't found the label in the bitmap, it may
8841 still be the label of the END of the enclosing block, in which
8842 case we find it by going up the code_stack. */
8844 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
8846 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
8848 if (stack
->current
->op
== EXEC_CRITICAL
)
8850 /* Note: A label at END CRITICAL does not leave the CRITICAL
8851 construct as END CRITICAL is still part of it. */
8852 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
8853 " at %L", &code
->loc
, &label
->where
);
8856 else if (stack
->current
->op
== EXEC_DO_CONCURRENT
)
8858 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for "
8859 "label at %L", &code
->loc
, &label
->where
);
8866 gcc_assert (stack
->current
->next
->op
== EXEC_END_NESTED_BLOCK
);
8870 /* The label is not in an enclosing block, so illegal. This was
8871 allowed in Fortran 66, so we allow it as extension. No
8872 further checks are necessary in this case. */
8873 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
8874 "as the GOTO statement at %L", &label
->where
,
8880 /* Check whether EXPR1 has the same shape as EXPR2. */
8883 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
8885 mpz_t shape
[GFC_MAX_DIMENSIONS
];
8886 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
8887 gfc_try result
= FAILURE
;
8890 /* Compare the rank. */
8891 if (expr1
->rank
!= expr2
->rank
)
8894 /* Compare the size of each dimension. */
8895 for (i
=0; i
<expr1
->rank
; i
++)
8897 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
8900 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
8903 if (mpz_cmp (shape
[i
], shape2
[i
]))
8907 /* When either of the two expression is an assumed size array, we
8908 ignore the comparison of dimension sizes. */
8913 gfc_clear_shape (shape
, i
);
8914 gfc_clear_shape (shape2
, i
);
8919 /* Check whether a WHERE assignment target or a WHERE mask expression
8920 has the same shape as the outmost WHERE mask expression. */
8923 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
8929 cblock
= code
->block
;
8931 /* Store the first WHERE mask-expr of the WHERE statement or construct.
8932 In case of nested WHERE, only the outmost one is stored. */
8933 if (mask
== NULL
) /* outmost WHERE */
8935 else /* inner WHERE */
8942 /* Check if the mask-expr has a consistent shape with the
8943 outmost WHERE mask-expr. */
8944 if (resolve_where_shape (cblock
->expr1
, e
) == FAILURE
)
8945 gfc_error ("WHERE mask at %L has inconsistent shape",
8946 &cblock
->expr1
->where
);
8949 /* the assignment statement of a WHERE statement, or the first
8950 statement in where-body-construct of a WHERE construct */
8951 cnext
= cblock
->next
;
8956 /* WHERE assignment statement */
8959 /* Check shape consistent for WHERE assignment target. */
8960 if (e
&& resolve_where_shape (cnext
->expr1
, e
) == FAILURE
)
8961 gfc_error ("WHERE assignment target at %L has "
8962 "inconsistent shape", &cnext
->expr1
->where
);
8966 case EXEC_ASSIGN_CALL
:
8967 resolve_call (cnext
);
8968 if (!cnext
->resolved_sym
->attr
.elemental
)
8969 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
8970 &cnext
->ext
.actual
->expr
->where
);
8973 /* WHERE or WHERE construct is part of a where-body-construct */
8975 resolve_where (cnext
, e
);
8979 gfc_error ("Unsupported statement inside WHERE at %L",
8982 /* the next statement within the same where-body-construct */
8983 cnext
= cnext
->next
;
8985 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
8986 cblock
= cblock
->block
;
8991 /* Resolve assignment in FORALL construct.
8992 NVAR is the number of FORALL index variables, and VAR_EXPR records the
8993 FORALL index variables. */
8996 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9000 for (n
= 0; n
< nvar
; n
++)
9002 gfc_symbol
*forall_index
;
9004 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
9006 /* Check whether the assignment target is one of the FORALL index
9008 if ((code
->expr1
->expr_type
== EXPR_VARIABLE
)
9009 && (code
->expr1
->symtree
->n
.sym
== forall_index
))
9010 gfc_error ("Assignment to a FORALL index variable at %L",
9011 &code
->expr1
->where
);
9014 /* If one of the FORALL index variables doesn't appear in the
9015 assignment variable, then there could be a many-to-one
9016 assignment. Emit a warning rather than an error because the
9017 mask could be resolving this problem. */
9018 if (find_forall_index (code
->expr1
, forall_index
, 0) == FAILURE
)
9019 gfc_warning ("The FORALL with index '%s' is not used on the "
9020 "left side of the assignment at %L and so might "
9021 "cause multiple assignment to this object",
9022 var_expr
[n
]->symtree
->name
, &code
->expr1
->where
);
9028 /* Resolve WHERE statement in FORALL construct. */
9031 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
9032 gfc_expr
**var_expr
)
9037 cblock
= code
->block
;
9040 /* the assignment statement of a WHERE statement, or the first
9041 statement in where-body-construct of a WHERE construct */
9042 cnext
= cblock
->next
;
9047 /* WHERE assignment statement */
9049 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
9052 /* WHERE operator assignment statement */
9053 case EXEC_ASSIGN_CALL
:
9054 resolve_call (cnext
);
9055 if (!cnext
->resolved_sym
->attr
.elemental
)
9056 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
9057 &cnext
->ext
.actual
->expr
->where
);
9060 /* WHERE or WHERE construct is part of a where-body-construct */
9062 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
9066 gfc_error ("Unsupported statement inside WHERE at %L",
9069 /* the next statement within the same where-body-construct */
9070 cnext
= cnext
->next
;
9072 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
9073 cblock
= cblock
->block
;
9078 /* Traverse the FORALL body to check whether the following errors exist:
9079 1. For assignment, check if a many-to-one assignment happens.
9080 2. For WHERE statement, check the WHERE body to see if there is any
9081 many-to-one assignment. */
9084 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
9088 c
= code
->block
->next
;
9094 case EXEC_POINTER_ASSIGN
:
9095 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
9098 case EXEC_ASSIGN_CALL
:
9102 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
9103 there is no need to handle it here. */
9107 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
9112 /* The next statement in the FORALL body. */
9118 /* Counts the number of iterators needed inside a forall construct, including
9119 nested forall constructs. This is used to allocate the needed memory
9120 in gfc_resolve_forall. */
9123 gfc_count_forall_iterators (gfc_code
*code
)
9125 int max_iters
, sub_iters
, current_iters
;
9126 gfc_forall_iterator
*fa
;
9128 gcc_assert(code
->op
== EXEC_FORALL
);
9132 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9135 code
= code
->block
->next
;
9139 if (code
->op
== EXEC_FORALL
)
9141 sub_iters
= gfc_count_forall_iterators (code
);
9142 if (sub_iters
> max_iters
)
9143 max_iters
= sub_iters
;
9148 return current_iters
+ max_iters
;
9152 /* Given a FORALL construct, first resolve the FORALL iterator, then call
9153 gfc_resolve_forall_body to resolve the FORALL body. */
9156 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
9158 static gfc_expr
**var_expr
;
9159 static int total_var
= 0;
9160 static int nvar
= 0;
9162 gfc_forall_iterator
*fa
;
9167 /* Start to resolve a FORALL construct */
9168 if (forall_save
== 0)
9170 /* Count the total number of FORALL index in the nested FORALL
9171 construct in order to allocate the VAR_EXPR with proper size. */
9172 total_var
= gfc_count_forall_iterators (code
);
9174 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
9175 var_expr
= XCNEWVEC (gfc_expr
*, total_var
);
9178 /* The information about FORALL iterator, including FORALL index start, end
9179 and stride. The FORALL index can not appear in start, end or stride. */
9180 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
9182 /* Check if any outer FORALL index name is the same as the current
9184 for (i
= 0; i
< nvar
; i
++)
9186 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
9188 gfc_error ("An outer FORALL construct already has an index "
9189 "with this name %L", &fa
->var
->where
);
9193 /* Record the current FORALL index. */
9194 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
9198 /* No memory leak. */
9199 gcc_assert (nvar
<= total_var
);
9202 /* Resolve the FORALL body. */
9203 gfc_resolve_forall_body (code
, nvar
, var_expr
);
9205 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
9206 gfc_resolve_blocks (code
->block
, ns
);
9210 /* Free only the VAR_EXPRs allocated in this frame. */
9211 for (i
= nvar
; i
< tmp
; i
++)
9212 gfc_free_expr (var_expr
[i
]);
9216 /* We are in the outermost FORALL construct. */
9217 gcc_assert (forall_save
== 0);
9219 /* VAR_EXPR is not needed any more. */
9226 /* Resolve a BLOCK construct statement. */
9229 resolve_block_construct (gfc_code
* code
)
9231 /* Resolve the BLOCK's namespace. */
9232 gfc_resolve (code
->ext
.block
.ns
);
9234 /* For an ASSOCIATE block, the associations (and their targets) are already
9235 resolved during resolve_symbol. */
9239 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
9242 static void resolve_code (gfc_code
*, gfc_namespace
*);
9245 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
9249 for (; b
; b
= b
->block
)
9251 t
= gfc_resolve_expr (b
->expr1
);
9252 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
9258 if (t
== SUCCESS
&& b
->expr1
!= NULL
9259 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
!= 0))
9260 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9267 && (b
->expr1
->ts
.type
!= BT_LOGICAL
|| b
->expr1
->rank
== 0))
9268 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
9273 resolve_branch (b
->label1
, b
);
9277 resolve_block_construct (b
);
9281 case EXEC_SELECT_TYPE
:
9285 case EXEC_DO_CONCURRENT
:
9293 case EXEC_OMP_ATOMIC
:
9294 case EXEC_OMP_CRITICAL
:
9296 case EXEC_OMP_MASTER
:
9297 case EXEC_OMP_ORDERED
:
9298 case EXEC_OMP_PARALLEL
:
9299 case EXEC_OMP_PARALLEL_DO
:
9300 case EXEC_OMP_PARALLEL_SECTIONS
:
9301 case EXEC_OMP_PARALLEL_WORKSHARE
:
9302 case EXEC_OMP_SECTIONS
:
9303 case EXEC_OMP_SINGLE
:
9305 case EXEC_OMP_TASKWAIT
:
9306 case EXEC_OMP_TASKYIELD
:
9307 case EXEC_OMP_WORKSHARE
:
9311 gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
9314 resolve_code (b
->next
, ns
);
9319 /* Does everything to resolve an ordinary assignment. Returns true
9320 if this is an interface assignment. */
9322 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
9332 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
9336 if (code
->op
== EXEC_ASSIGN_CALL
)
9338 lhs
= code
->ext
.actual
->expr
;
9339 rhsptr
= &code
->ext
.actual
->next
->expr
;
9343 gfc_actual_arglist
* args
;
9344 gfc_typebound_proc
* tbp
;
9346 gcc_assert (code
->op
== EXEC_COMPCALL
);
9348 args
= code
->expr1
->value
.compcall
.actual
;
9350 rhsptr
= &args
->next
->expr
;
9352 tbp
= code
->expr1
->value
.compcall
.tbp
;
9353 gcc_assert (!tbp
->is_generic
);
9356 /* Make a temporary rhs when there is a default initializer
9357 and rhs is the same symbol as the lhs. */
9358 if ((*rhsptr
)->expr_type
== EXPR_VARIABLE
9359 && (*rhsptr
)->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9360 && gfc_has_default_initializer ((*rhsptr
)->symtree
->n
.sym
->ts
.u
.derived
)
9361 && (lhs
->symtree
->n
.sym
== (*rhsptr
)->symtree
->n
.sym
))
9362 *rhsptr
= gfc_get_parentheses (*rhsptr
);
9371 && gfc_notify_std (GFC_STD_GNU
, "BOZ literal at %L outside "
9372 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
9373 &code
->loc
) == FAILURE
)
9376 /* Handle the case of a BOZ literal on the RHS. */
9377 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
9380 if (gfc_option
.warn_surprising
)
9381 gfc_warning ("BOZ literal at %L is bitwise transferred "
9382 "non-integer symbol '%s'", &code
->loc
,
9383 lhs
->symtree
->n
.sym
->name
);
9385 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
9387 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
9389 if (rc
== ARITH_UNDERFLOW
)
9390 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
9391 ". This check can be disabled with the option "
9392 "-fno-range-check", &rhs
->where
);
9393 else if (rc
== ARITH_OVERFLOW
)
9394 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
9395 ". This check can be disabled with the option "
9396 "-fno-range-check", &rhs
->where
);
9397 else if (rc
== ARITH_NAN
)
9398 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
9399 ". This check can be disabled with the option "
9400 "-fno-range-check", &rhs
->where
);
9405 if (lhs
->ts
.type
== BT_CHARACTER
9406 && gfc_option
.warn_character_truncation
)
9408 if (lhs
->ts
.u
.cl
!= NULL
9409 && lhs
->ts
.u
.cl
->length
!= NULL
9410 && lhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9411 llen
= mpz_get_si (lhs
->ts
.u
.cl
->length
->value
.integer
);
9413 if (rhs
->expr_type
== EXPR_CONSTANT
)
9414 rlen
= rhs
->value
.character
.length
;
9416 else if (rhs
->ts
.u
.cl
!= NULL
9417 && rhs
->ts
.u
.cl
->length
!= NULL
9418 && rhs
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
9419 rlen
= mpz_get_si (rhs
->ts
.u
.cl
->length
->value
.integer
);
9421 if (rlen
&& llen
&& rlen
> llen
)
9422 gfc_warning_now ("CHARACTER expression will be truncated "
9423 "in assignment (%d/%d) at %L",
9424 llen
, rlen
, &code
->loc
);
9427 /* Ensure that a vector index expression for the lvalue is evaluated
9428 to a temporary if the lvalue symbol is referenced in it. */
9431 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
9432 if (ref
->type
== REF_ARRAY
)
9434 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
9435 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
9436 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
9437 ref
->u
.ar
.start
[n
]))
9439 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
9443 if (gfc_pure (NULL
))
9445 if (lhs
->ts
.type
== BT_DERIVED
9446 && lhs
->expr_type
== EXPR_VARIABLE
9447 && lhs
->ts
.u
.derived
->attr
.pointer_comp
9448 && rhs
->expr_type
== EXPR_VARIABLE
9449 && (gfc_impure_variable (rhs
->symtree
->n
.sym
)
9450 || gfc_is_coindexed (rhs
)))
9453 if (gfc_is_coindexed (rhs
))
9454 gfc_error ("Coindexed expression at %L is assigned to "
9455 "a derived type variable with a POINTER "
9456 "component in a PURE procedure",
9459 gfc_error ("The impure variable at %L is assigned to "
9460 "a derived type variable with a POINTER "
9461 "component in a PURE procedure (12.6)",
9466 /* Fortran 2008, C1283. */
9467 if (gfc_is_coindexed (lhs
))
9469 gfc_error ("Assignment to coindexed variable at %L in a PURE "
9470 "procedure", &rhs
->where
);
9475 if (gfc_implicit_pure (NULL
))
9477 if (lhs
->expr_type
== EXPR_VARIABLE
9478 && lhs
->symtree
->n
.sym
!= gfc_current_ns
->proc_name
9479 && lhs
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
9480 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
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
)))
9488 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9490 /* Fortran 2008, C1283. */
9491 if (gfc_is_coindexed (lhs
))
9492 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
9496 /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
9497 and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
9498 if (lhs
->ts
.type
== BT_CLASS
)
9500 gfc_error ("Variable must not be polymorphic in intrinsic assignment at "
9501 "%L - check that there is a matching specific subroutine "
9502 "for '=' operator", &lhs
->where
);
9506 /* F2008, Section 7.2.1.2. */
9507 if (gfc_is_coindexed (lhs
) && gfc_has_ultimate_allocatable (lhs
))
9509 gfc_error ("Coindexed variable must not be have an allocatable ultimate "
9510 "component in assignment at %L", &lhs
->where
);
9514 gfc_check_assign (lhs
, rhs
, 1);
9519 /* Given a block of code, recursively resolve everything pointed to by this
9523 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
9525 int omp_workshare_save
;
9526 int forall_save
, do_concurrent_save
;
9530 frame
.prev
= cs_base
;
9534 find_reachable_labels (code
);
9536 for (; code
; code
= code
->next
)
9538 frame
.current
= code
;
9539 forall_save
= forall_flag
;
9540 do_concurrent_save
= do_concurrent_flag
;
9542 if (code
->op
== EXEC_FORALL
)
9545 gfc_resolve_forall (code
, ns
, forall_save
);
9548 else if (code
->block
)
9550 omp_workshare_save
= -1;
9553 case EXEC_OMP_PARALLEL_WORKSHARE
:
9554 omp_workshare_save
= omp_workshare_flag
;
9555 omp_workshare_flag
= 1;
9556 gfc_resolve_omp_parallel_blocks (code
, ns
);
9558 case EXEC_OMP_PARALLEL
:
9559 case EXEC_OMP_PARALLEL_DO
:
9560 case EXEC_OMP_PARALLEL_SECTIONS
:
9562 omp_workshare_save
= omp_workshare_flag
;
9563 omp_workshare_flag
= 0;
9564 gfc_resolve_omp_parallel_blocks (code
, ns
);
9567 gfc_resolve_omp_do_blocks (code
, ns
);
9569 case EXEC_SELECT_TYPE
:
9570 /* Blocks are handled in resolve_select_type because we have
9571 to transform the SELECT TYPE into ASSOCIATE first. */
9573 case EXEC_DO_CONCURRENT
:
9574 do_concurrent_flag
= 1;
9575 gfc_resolve_blocks (code
->block
, ns
);
9576 do_concurrent_flag
= 2;
9578 case EXEC_OMP_WORKSHARE
:
9579 omp_workshare_save
= omp_workshare_flag
;
9580 omp_workshare_flag
= 1;
9583 gfc_resolve_blocks (code
->block
, ns
);
9587 if (omp_workshare_save
!= -1)
9588 omp_workshare_flag
= omp_workshare_save
;
9592 if (code
->op
!= EXEC_COMPCALL
&& code
->op
!= EXEC_CALL_PPC
)
9593 t
= gfc_resolve_expr (code
->expr1
);
9594 forall_flag
= forall_save
;
9595 do_concurrent_flag
= do_concurrent_save
;
9597 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
9600 if (code
->op
== EXEC_ALLOCATE
9601 && gfc_resolve_expr (code
->expr3
) == FAILURE
)
9607 case EXEC_END_BLOCK
:
9608 case EXEC_END_NESTED_BLOCK
:
9612 case EXEC_ERROR_STOP
:
9616 case EXEC_ASSIGN_CALL
:
9621 case EXEC_SYNC_IMAGES
:
9622 case EXEC_SYNC_MEMORY
:
9623 resolve_sync (code
);
9628 resolve_lock_unlock (code
);
9632 /* Keep track of which entry we are up to. */
9633 current_entry_id
= code
->ext
.entry
->id
;
9637 resolve_where (code
, NULL
);
9641 if (code
->expr1
!= NULL
)
9643 if (code
->expr1
->ts
.type
!= BT_INTEGER
)
9644 gfc_error ("ASSIGNED GOTO statement at %L requires an "
9645 "INTEGER variable", &code
->expr1
->where
);
9646 else if (code
->expr1
->symtree
->n
.sym
->attr
.assign
!= 1)
9647 gfc_error ("Variable '%s' has not been assigned a target "
9648 "label at %L", code
->expr1
->symtree
->n
.sym
->name
,
9649 &code
->expr1
->where
);
9652 resolve_branch (code
->label1
, code
);
9656 if (code
->expr1
!= NULL
9657 && (code
->expr1
->ts
.type
!= BT_INTEGER
|| code
->expr1
->rank
))
9658 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
9659 "INTEGER return specifier", &code
->expr1
->where
);
9662 case EXEC_INIT_ASSIGN
:
9663 case EXEC_END_PROCEDURE
:
9670 if (gfc_check_vardef_context (code
->expr1
, false, false,
9671 _("assignment")) == FAILURE
)
9674 if (resolve_ordinary_assign (code
, ns
))
9676 if (code
->op
== EXEC_COMPCALL
)
9683 case EXEC_LABEL_ASSIGN
:
9684 if (code
->label1
->defined
== ST_LABEL_UNKNOWN
)
9685 gfc_error ("Label %d referenced at %L is never defined",
9686 code
->label1
->value
, &code
->label1
->where
);
9688 && (code
->expr1
->expr_type
!= EXPR_VARIABLE
9689 || code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
9690 || code
->expr1
->symtree
->n
.sym
->ts
.kind
9691 != gfc_default_integer_kind
9692 || code
->expr1
->symtree
->n
.sym
->as
!= NULL
))
9693 gfc_error ("ASSIGN statement at %L requires a scalar "
9694 "default INTEGER variable", &code
->expr1
->where
);
9697 case EXEC_POINTER_ASSIGN
:
9704 /* This is both a variable definition and pointer assignment
9705 context, so check both of them. For rank remapping, a final
9706 array ref may be present on the LHS and fool gfc_expr_attr
9707 used in gfc_check_vardef_context. Remove it. */
9708 e
= remove_last_array_ref (code
->expr1
);
9709 t
= gfc_check_vardef_context (e
, true, false,
9710 _("pointer assignment"));
9712 t
= gfc_check_vardef_context (e
, false, false,
9713 _("pointer assignment"));
9718 gfc_check_pointer_assign (code
->expr1
, code
->expr2
);
9722 case EXEC_ARITHMETIC_IF
:
9724 && code
->expr1
->ts
.type
!= BT_INTEGER
9725 && code
->expr1
->ts
.type
!= BT_REAL
)
9726 gfc_error ("Arithmetic IF statement at %L requires a numeric "
9727 "expression", &code
->expr1
->where
);
9729 resolve_branch (code
->label1
, code
);
9730 resolve_branch (code
->label2
, code
);
9731 resolve_branch (code
->label3
, code
);
9735 if (t
== SUCCESS
&& code
->expr1
!= NULL
9736 && (code
->expr1
->ts
.type
!= BT_LOGICAL
9737 || code
->expr1
->rank
!= 0))
9738 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9739 &code
->expr1
->where
);
9744 resolve_call (code
);
9749 resolve_typebound_subroutine (code
);
9753 resolve_ppc_call (code
);
9757 /* Select is complicated. Also, a SELECT construct could be
9758 a transformed computed GOTO. */
9759 resolve_select (code
);
9762 case EXEC_SELECT_TYPE
:
9763 resolve_select_type (code
, ns
);
9767 resolve_block_construct (code
);
9771 if (code
->ext
.iterator
!= NULL
)
9773 gfc_iterator
*iter
= code
->ext
.iterator
;
9774 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
9775 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
9780 if (code
->expr1
== NULL
)
9781 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
9783 && (code
->expr1
->rank
!= 0
9784 || code
->expr1
->ts
.type
!= BT_LOGICAL
))
9785 gfc_error ("Exit condition of DO WHILE loop at %L must be "
9786 "a scalar LOGICAL expression", &code
->expr1
->where
);
9791 resolve_allocate_deallocate (code
, "ALLOCATE");
9795 case EXEC_DEALLOCATE
:
9797 resolve_allocate_deallocate (code
, "DEALLOCATE");
9802 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
9805 resolve_branch (code
->ext
.open
->err
, code
);
9809 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
9812 resolve_branch (code
->ext
.close
->err
, code
);
9815 case EXEC_BACKSPACE
:
9819 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
9822 resolve_branch (code
->ext
.filepos
->err
, code
);
9826 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9829 resolve_branch (code
->ext
.inquire
->err
, code
);
9833 gcc_assert (code
->ext
.inquire
!= NULL
);
9834 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
9837 resolve_branch (code
->ext
.inquire
->err
, code
);
9841 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
9844 resolve_branch (code
->ext
.wait
->err
, code
);
9845 resolve_branch (code
->ext
.wait
->end
, code
);
9846 resolve_branch (code
->ext
.wait
->eor
, code
);
9851 if (gfc_resolve_dt (code
->ext
.dt
, &code
->loc
) == FAILURE
)
9854 resolve_branch (code
->ext
.dt
->err
, code
);
9855 resolve_branch (code
->ext
.dt
->end
, code
);
9856 resolve_branch (code
->ext
.dt
->eor
, code
);
9860 resolve_transfer (code
);
9863 case EXEC_DO_CONCURRENT
:
9865 resolve_forall_iterators (code
->ext
.forall_iterator
);
9867 if (code
->expr1
!= NULL
9868 && (code
->expr1
->ts
.type
!= BT_LOGICAL
|| code
->expr1
->rank
))
9869 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
9870 "expression", &code
->expr1
->where
);
9873 case EXEC_OMP_ATOMIC
:
9874 case EXEC_OMP_BARRIER
:
9875 case EXEC_OMP_CRITICAL
:
9876 case EXEC_OMP_FLUSH
:
9878 case EXEC_OMP_MASTER
:
9879 case EXEC_OMP_ORDERED
:
9880 case EXEC_OMP_SECTIONS
:
9881 case EXEC_OMP_SINGLE
:
9882 case EXEC_OMP_TASKWAIT
:
9883 case EXEC_OMP_TASKYIELD
:
9884 case EXEC_OMP_WORKSHARE
:
9885 gfc_resolve_omp_directive (code
, ns
);
9888 case EXEC_OMP_PARALLEL
:
9889 case EXEC_OMP_PARALLEL_DO
:
9890 case EXEC_OMP_PARALLEL_SECTIONS
:
9891 case EXEC_OMP_PARALLEL_WORKSHARE
:
9893 omp_workshare_save
= omp_workshare_flag
;
9894 omp_workshare_flag
= 0;
9895 gfc_resolve_omp_directive (code
, ns
);
9896 omp_workshare_flag
= omp_workshare_save
;
9900 gfc_internal_error ("resolve_code(): Bad statement code");
9904 cs_base
= frame
.prev
;
9908 /* Resolve initial values and make sure they are compatible with
9912 resolve_values (gfc_symbol
*sym
)
9916 if (sym
->value
== NULL
)
9919 if (sym
->value
->expr_type
== EXPR_STRUCTURE
)
9920 t
= resolve_structure_cons (sym
->value
, 1);
9922 t
= gfc_resolve_expr (sym
->value
);
9927 gfc_check_assign_symbol (sym
, sym
->value
);
9931 /* Verify the binding labels for common blocks that are BIND(C). The label
9932 for a BIND(C) common block must be identical in all scoping units in which
9933 the common block is declared. Further, the binding label can not collide
9934 with any other global entity in the program. */
9937 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
9939 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
9941 gfc_gsymbol
*binding_label_gsym
;
9942 gfc_gsymbol
*comm_name_gsym
;
9943 const char * bind_label
= comm_block_tree
->n
.common
->binding_label
9944 ? comm_block_tree
->n
.common
->binding_label
: "";
9946 /* See if a global symbol exists by the common block's name. It may
9947 be NULL if the common block is use-associated. */
9948 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
9949 comm_block_tree
->n
.common
->name
);
9950 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
9951 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
9952 "with the global entity '%s' at %L",
9954 comm_block_tree
->n
.common
->name
,
9955 &(comm_block_tree
->n
.common
->where
),
9956 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
9957 else if (comm_name_gsym
!= NULL
9958 && strcmp (comm_name_gsym
->name
,
9959 comm_block_tree
->n
.common
->name
) == 0)
9961 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
9963 if (comm_name_gsym
->binding_label
== NULL
)
9964 /* No binding label for common block stored yet; save this one. */
9965 comm_name_gsym
->binding_label
= bind_label
;
9966 else if (strcmp (comm_name_gsym
->binding_label
, bind_label
) != 0)
9968 /* Common block names match but binding labels do not. */
9969 gfc_error ("Binding label '%s' for common block '%s' at %L "
9970 "does not match the binding label '%s' for common "
9973 comm_block_tree
->n
.common
->name
,
9974 &(comm_block_tree
->n
.common
->where
),
9975 comm_name_gsym
->binding_label
,
9976 comm_name_gsym
->name
,
9977 &(comm_name_gsym
->where
));
9982 /* There is no binding label (NAME="") so we have nothing further to
9983 check and nothing to add as a global symbol for the label. */
9984 if (!comm_block_tree
->n
.common
->binding_label
)
9987 binding_label_gsym
=
9988 gfc_find_gsymbol (gfc_gsym_root
,
9989 comm_block_tree
->n
.common
->binding_label
);
9990 if (binding_label_gsym
== NULL
)
9992 /* Need to make a global symbol for the binding label to prevent
9993 it from colliding with another. */
9994 binding_label_gsym
=
9995 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
9996 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
9997 binding_label_gsym
->type
= GSYM_COMMON
;
10001 /* If comm_name_gsym is NULL, the name common block is use
10002 associated and the name could be colliding. */
10003 if (binding_label_gsym
->type
!= GSYM_COMMON
)
10004 gfc_error ("Binding label '%s' for common block '%s' at %L "
10005 "collides with the global entity '%s' at %L",
10006 comm_block_tree
->n
.common
->binding_label
,
10007 comm_block_tree
->n
.common
->name
,
10008 &(comm_block_tree
->n
.common
->where
),
10009 binding_label_gsym
->name
,
10010 &(binding_label_gsym
->where
));
10011 else if (comm_name_gsym
!= NULL
10012 && (strcmp (binding_label_gsym
->name
,
10013 comm_name_gsym
->binding_label
) != 0)
10014 && (strcmp (binding_label_gsym
->sym_name
,
10015 comm_name_gsym
->name
) != 0))
10016 gfc_error ("Binding label '%s' for common block '%s' at %L "
10017 "collides with global entity '%s' at %L",
10018 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
10019 &(comm_block_tree
->n
.common
->where
),
10020 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
10028 /* Verify any BIND(C) derived types in the namespace so we can report errors
10029 for them once, rather than for each variable declared of that type. */
10032 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
10034 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
10035 && derived_sym
->attr
.is_bind_c
== 1)
10036 verify_bind_c_derived_type (derived_sym
);
10042 /* Verify that any binding labels used in a given namespace do not collide
10043 with the names or binding labels of any global symbols. */
10046 gfc_verify_binding_labels (gfc_symbol
*sym
)
10050 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
10051 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
)
10053 gfc_gsymbol
*bind_c_sym
;
10055 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
10056 if (bind_c_sym
!= NULL
10057 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
10059 if (sym
->attr
.if_source
== IFSRC_DECL
10060 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
10061 && bind_c_sym
->type
!= GSYM_FUNCTION
)
10062 && ((sym
->attr
.contained
== 1
10063 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
10064 || (sym
->attr
.use_assoc
== 1
10065 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
10067 /* Make sure global procedures don't collide with anything. */
10068 gfc_error ("Binding label '%s' at %L collides with the global "
10069 "entity '%s' at %L", sym
->binding_label
,
10070 &(sym
->declared_at
), bind_c_sym
->name
,
10071 &(bind_c_sym
->where
));
10074 else if (sym
->attr
.contained
== 0
10075 && (sym
->attr
.if_source
== IFSRC_IFBODY
10076 && sym
->attr
.flavor
== FL_PROCEDURE
)
10077 && (bind_c_sym
->sym_name
!= NULL
10078 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
10080 /* Make sure procedures in interface bodies don't collide. */
10081 gfc_error ("Binding label '%s' in interface body at %L collides "
10082 "with the global entity '%s' at %L",
10083 sym
->binding_label
,
10084 &(sym
->declared_at
), bind_c_sym
->name
,
10085 &(bind_c_sym
->where
));
10088 else if (sym
->attr
.contained
== 0
10089 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
10090 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
10091 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
10092 || sym
->attr
.use_assoc
== 0)
10094 gfc_error ("Binding label '%s' at %L collides with global "
10095 "entity '%s' at %L", sym
->binding_label
,
10096 &(sym
->declared_at
), bind_c_sym
->name
,
10097 &(bind_c_sym
->where
));
10101 if (has_error
!= 0)
10102 /* Clear the binding label to prevent checking multiple times. */
10103 sym
->binding_label
= NULL
;
10105 else if (bind_c_sym
== NULL
)
10107 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
10108 bind_c_sym
->where
= sym
->declared_at
;
10109 bind_c_sym
->sym_name
= sym
->name
;
10111 if (sym
->attr
.use_assoc
== 1)
10112 bind_c_sym
->mod_name
= sym
->module
;
10114 if (sym
->ns
->proc_name
!= NULL
)
10115 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
10117 if (sym
->attr
.contained
== 0)
10119 if (sym
->attr
.subroutine
)
10120 bind_c_sym
->type
= GSYM_SUBROUTINE
;
10121 else if (sym
->attr
.function
)
10122 bind_c_sym
->type
= GSYM_FUNCTION
;
10130 /* Resolve an index expression. */
10133 resolve_index_expr (gfc_expr
*e
)
10135 if (gfc_resolve_expr (e
) == FAILURE
)
10138 if (gfc_simplify_expr (e
, 0) == FAILURE
)
10141 if (gfc_specification_expr (e
) == FAILURE
)
10148 /* Resolve a charlen structure. */
10151 resolve_charlen (gfc_charlen
*cl
)
10161 if (cl
->length_from_typespec
)
10163 if (gfc_resolve_expr (cl
->length
) == FAILURE
)
10166 if (gfc_simplify_expr (cl
->length
, 0) == FAILURE
)
10171 specification_expr
= 1;
10173 if (resolve_index_expr (cl
->length
) == FAILURE
)
10175 specification_expr
= 0;
10180 /* "If the character length parameter value evaluates to a negative
10181 value, the length of character entities declared is zero." */
10182 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
10184 if (gfc_option
.warn_surprising
)
10185 gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
10186 " the length has been set to zero",
10187 &cl
->length
->where
, i
);
10188 gfc_replace_expr (cl
->length
,
10189 gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 0));
10192 /* Check that the character length is not too large. */
10193 k
= gfc_validate_kind (BT_INTEGER
, gfc_charlen_int_kind
, false);
10194 if (cl
->length
&& cl
->length
->expr_type
== EXPR_CONSTANT
10195 && cl
->length
->ts
.type
== BT_INTEGER
10196 && mpz_cmp (cl
->length
->value
.integer
, gfc_integer_kinds
[k
].huge
) > 0)
10198 gfc_error ("String length at %L is too large", &cl
->length
->where
);
10206 /* Test for non-constant shape arrays. */
10209 is_non_constant_shape_array (gfc_symbol
*sym
)
10215 not_constant
= false;
10216 if (sym
->as
!= NULL
)
10218 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
10219 has not been simplified; parameter array references. Do the
10220 simplification now. */
10221 for (i
= 0; i
< sym
->as
->rank
+ sym
->as
->corank
; i
++)
10223 e
= sym
->as
->lower
[i
];
10224 if (e
&& (resolve_index_expr (e
) == FAILURE
10225 || !gfc_is_constant_expr (e
)))
10226 not_constant
= true;
10227 e
= sym
->as
->upper
[i
];
10228 if (e
&& (resolve_index_expr (e
) == FAILURE
10229 || !gfc_is_constant_expr (e
)))
10230 not_constant
= true;
10233 return not_constant
;
10236 /* Given a symbol and an initialization expression, add code to initialize
10237 the symbol to the function entry. */
10239 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
10243 gfc_namespace
*ns
= sym
->ns
;
10245 /* Search for the function namespace if this is a contained
10246 function without an explicit result. */
10247 if (sym
->attr
.function
&& sym
== sym
->result
10248 && sym
->name
!= sym
->ns
->proc_name
->name
)
10250 ns
= ns
->contained
;
10251 for (;ns
; ns
= ns
->sibling
)
10252 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
10258 gfc_free_expr (init
);
10262 /* Build an l-value expression for the result. */
10263 lval
= gfc_lval_expr_from_sym (sym
);
10265 /* Add the code at scope entry. */
10266 init_st
= gfc_get_code ();
10267 init_st
->next
= ns
->code
;
10268 ns
->code
= init_st
;
10270 /* Assign the default initializer to the l-value. */
10271 init_st
->loc
= sym
->declared_at
;
10272 init_st
->op
= EXEC_INIT_ASSIGN
;
10273 init_st
->expr1
= lval
;
10274 init_st
->expr2
= init
;
10277 /* Assign the default initializer to a derived type variable or result. */
10280 apply_default_init (gfc_symbol
*sym
)
10282 gfc_expr
*init
= NULL
;
10284 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10287 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
)
10288 init
= gfc_default_initializer (&sym
->ts
);
10290 if (init
== NULL
&& sym
->ts
.type
!= BT_CLASS
)
10293 build_init_assign (sym
, init
);
10294 sym
->attr
.referenced
= 1;
10297 /* Build an initializer for a local integer, real, complex, logical, or
10298 character variable, based on the command line flags finit-local-zero,
10299 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
10300 null if the symbol should not have a default initialization. */
10302 build_default_init_expr (gfc_symbol
*sym
)
10305 gfc_expr
*init_expr
;
10308 /* These symbols should never have a default initialization. */
10309 if (sym
->attr
.allocatable
10310 || sym
->attr
.external
10312 || sym
->attr
.pointer
10313 || sym
->attr
.in_equivalence
10314 || sym
->attr
.in_common
10317 || sym
->attr
.cray_pointee
10318 || sym
->attr
.cray_pointer
10322 /* Now we'll try to build an initializer expression. */
10323 init_expr
= gfc_get_constant_expr (sym
->ts
.type
, sym
->ts
.kind
,
10324 &sym
->declared_at
);
10326 /* We will only initialize integers, reals, complex, logicals, and
10327 characters, and only if the corresponding command-line flags
10328 were set. Otherwise, we free init_expr and return null. */
10329 switch (sym
->ts
.type
)
10332 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
10333 mpz_set_si (init_expr
->value
.integer
,
10334 gfc_option
.flag_init_integer_value
);
10337 gfc_free_expr (init_expr
);
10343 switch (gfc_option
.flag_init_real
)
10345 case GFC_INIT_REAL_SNAN
:
10346 init_expr
->is_snan
= 1;
10347 /* Fall through. */
10348 case GFC_INIT_REAL_NAN
:
10349 mpfr_set_nan (init_expr
->value
.real
);
10352 case GFC_INIT_REAL_INF
:
10353 mpfr_set_inf (init_expr
->value
.real
, 1);
10356 case GFC_INIT_REAL_NEG_INF
:
10357 mpfr_set_inf (init_expr
->value
.real
, -1);
10360 case GFC_INIT_REAL_ZERO
:
10361 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
10365 gfc_free_expr (init_expr
);
10372 switch (gfc_option
.flag_init_real
)
10374 case GFC_INIT_REAL_SNAN
:
10375 init_expr
->is_snan
= 1;
10376 /* Fall through. */
10377 case GFC_INIT_REAL_NAN
:
10378 mpfr_set_nan (mpc_realref (init_expr
->value
.complex));
10379 mpfr_set_nan (mpc_imagref (init_expr
->value
.complex));
10382 case GFC_INIT_REAL_INF
:
10383 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), 1);
10384 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), 1);
10387 case GFC_INIT_REAL_NEG_INF
:
10388 mpfr_set_inf (mpc_realref (init_expr
->value
.complex), -1);
10389 mpfr_set_inf (mpc_imagref (init_expr
->value
.complex), -1);
10392 case GFC_INIT_REAL_ZERO
:
10393 mpc_set_ui (init_expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
10397 gfc_free_expr (init_expr
);
10404 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
10405 init_expr
->value
.logical
= 0;
10406 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
10407 init_expr
->value
.logical
= 1;
10410 gfc_free_expr (init_expr
);
10416 /* For characters, the length must be constant in order to
10417 create a default initializer. */
10418 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10419 && sym
->ts
.u
.cl
->length
10420 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
10422 char_len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
10423 init_expr
->value
.character
.length
= char_len
;
10424 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
10425 for (i
= 0; i
< char_len
; i
++)
10426 init_expr
->value
.character
.string
[i
]
10427 = (unsigned char) gfc_option
.flag_init_character_value
;
10431 gfc_free_expr (init_expr
);
10434 if (!init_expr
&& gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
10435 && sym
->ts
.u
.cl
->length
)
10437 gfc_actual_arglist
*arg
;
10438 init_expr
= gfc_get_expr ();
10439 init_expr
->where
= sym
->declared_at
;
10440 init_expr
->ts
= sym
->ts
;
10441 init_expr
->expr_type
= EXPR_FUNCTION
;
10442 init_expr
->value
.function
.isym
=
10443 gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT
);
10444 init_expr
->value
.function
.name
= "repeat";
10445 arg
= gfc_get_actual_arglist ();
10446 arg
->expr
= gfc_get_character_expr (sym
->ts
.kind
, &sym
->declared_at
,
10448 arg
->expr
->value
.character
.string
[0]
10449 = gfc_option
.flag_init_character_value
;
10450 arg
->next
= gfc_get_actual_arglist ();
10451 arg
->next
->expr
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
10452 init_expr
->value
.function
.actual
= arg
;
10457 gfc_free_expr (init_expr
);
10463 /* Add an initialization expression to a local variable. */
10465 apply_default_init_local (gfc_symbol
*sym
)
10467 gfc_expr
*init
= NULL
;
10469 /* The symbol should be a variable or a function return value. */
10470 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
10471 || (sym
->attr
.function
&& sym
->result
!= sym
))
10474 /* Try to build the initializer expression. If we can't initialize
10475 this symbol, then init will be NULL. */
10476 init
= build_default_init_expr (sym
);
10480 /* For saved variables, we don't want to add an initializer at function
10481 entry, so we just add a static initializer. Note that automatic variables
10482 are stack allocated even with -fno-automatic. */
10483 if (sym
->attr
.save
|| sym
->ns
->save_all
10484 || (gfc_option
.flag_max_stack_var_size
== 0
10485 && (!sym
->attr
.dimension
|| !is_non_constant_shape_array (sym
))))
10487 /* Don't clobber an existing initializer! */
10488 gcc_assert (sym
->value
== NULL
);
10493 build_init_assign (sym
, init
);
10497 /* Resolution of common features of flavors variable and procedure. */
10500 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
10502 gfc_array_spec
*as
;
10504 /* Avoid double diagnostics for function result symbols. */
10505 if ((sym
->result
|| sym
->attr
.result
) && !sym
->attr
.dummy
10506 && (sym
->ns
!= gfc_current_ns
))
10509 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10510 as
= CLASS_DATA (sym
)->as
;
10514 /* Constraints on deferred shape variable. */
10515 if (as
== NULL
|| as
->type
!= AS_DEFERRED
)
10517 bool pointer
, allocatable
, dimension
;
10519 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
10521 pointer
= CLASS_DATA (sym
)->attr
.class_pointer
;
10522 allocatable
= CLASS_DATA (sym
)->attr
.allocatable
;
10523 dimension
= CLASS_DATA (sym
)->attr
.dimension
;
10527 pointer
= sym
->attr
.pointer
;
10528 allocatable
= sym
->attr
.allocatable
;
10529 dimension
= sym
->attr
.dimension
;
10534 if (dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10536 gfc_error ("Allocatable array '%s' at %L must have a deferred "
10537 "shape or assumed rank", sym
->name
, &sym
->declared_at
);
10540 else if (gfc_notify_std (GFC_STD_F2003
, "Scalar object "
10541 "'%s' at %L may not be ALLOCATABLE",
10542 sym
->name
, &sym
->declared_at
) == FAILURE
)
10546 if (pointer
&& dimension
&& as
->type
!= AS_ASSUMED_RANK
)
10548 gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
10549 "assumed rank", sym
->name
, &sym
->declared_at
);
10555 if (!mp_flag
&& !sym
->attr
.allocatable
&& !sym
->attr
.pointer
10556 && sym
->ts
.type
!= BT_CLASS
&& !sym
->assoc
)
10558 gfc_error ("Array '%s' at %L cannot have a deferred shape",
10559 sym
->name
, &sym
->declared_at
);
10564 /* Constraints on polymorphic variables. */
10565 if (sym
->ts
.type
== BT_CLASS
&& !(sym
->result
&& sym
->result
!= sym
))
10568 if (sym
->attr
.class_ok
10569 && !gfc_type_is_extensible (CLASS_DATA (sym
)->ts
.u
.derived
))
10571 gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
10572 CLASS_DATA (sym
)->ts
.u
.derived
->name
, sym
->name
,
10573 &sym
->declared_at
);
10578 /* Assume that use associated symbols were checked in the module ns.
10579 Class-variables that are associate-names are also something special
10580 and excepted from the test. */
10581 if (!sym
->attr
.class_ok
&& !sym
->attr
.use_assoc
&& !sym
->assoc
)
10583 gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
10584 "or pointer", sym
->name
, &sym
->declared_at
);
10593 /* Additional checks for symbols with flavor variable and derived
10594 type. To be called from resolve_fl_variable. */
10597 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
10599 gcc_assert (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
);
10601 /* Check to see if a derived type is blocked from being host
10602 associated by the presence of another class I symbol in the same
10603 namespace. 14.6.1.3 of the standard and the discussion on
10604 comp.lang.fortran. */
10605 if (sym
->ns
!= sym
->ts
.u
.derived
->ns
10606 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
10609 gfc_find_symbol (sym
->ts
.u
.derived
->name
, sym
->ns
, 0, &s
);
10610 if (s
&& s
->attr
.generic
)
10611 s
= gfc_find_dt_in_generic (s
);
10612 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
10614 gfc_error ("The type '%s' cannot be host associated at %L "
10615 "because it is blocked by an incompatible object "
10616 "of the same name declared at %L",
10617 sym
->ts
.u
.derived
->name
, &sym
->declared_at
,
10623 /* 4th constraint in section 11.3: "If an object of a type for which
10624 component-initialization is specified (R429) appears in the
10625 specification-part of a module and does not have the ALLOCATABLE
10626 or POINTER attribute, the object shall have the SAVE attribute."
10628 The check for initializers is performed with
10629 gfc_has_default_initializer because gfc_default_initializer generates
10630 a hidden default for allocatable components. */
10631 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
10632 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10633 && !sym
->ns
->save_all
&& !sym
->attr
.save
10634 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
10635 && gfc_has_default_initializer (sym
->ts
.u
.derived
)
10636 && gfc_notify_std (GFC_STD_F2008
, "Implied SAVE for "
10637 "module variable '%s' at %L, needed due to "
10638 "the default initialization", sym
->name
,
10639 &sym
->declared_at
) == FAILURE
)
10642 /* Assign default initializer. */
10643 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
10644 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
10646 sym
->value
= gfc_default_initializer (&sym
->ts
);
10653 /* Resolve symbols with flavor variable. */
10656 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
10658 int no_init_flag
, automatic_flag
;
10660 const char *auto_save_msg
;
10662 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
10665 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10668 /* Set this flag to check that variables are parameters of all entries.
10669 This check is effected by the call to gfc_resolve_expr through
10670 is_non_constant_shape_array. */
10671 specification_expr
= 1;
10673 if (sym
->ns
->proc_name
10674 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10675 || sym
->ns
->proc_name
->attr
.is_main_program
)
10676 && !sym
->attr
.use_assoc
10677 && !sym
->attr
.allocatable
10678 && !sym
->attr
.pointer
10679 && is_non_constant_shape_array (sym
))
10681 /* The shape of a main program or module array needs to be
10683 gfc_error ("The module or main program array '%s' at %L must "
10684 "have constant shape", sym
->name
, &sym
->declared_at
);
10685 specification_expr
= 0;
10689 /* Constraints on deferred type parameter. */
10690 if (sym
->ts
.deferred
&& !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
10692 gfc_error ("Entity '%s' at %L has a deferred type parameter and "
10693 "requires either the pointer or allocatable attribute",
10694 sym
->name
, &sym
->declared_at
);
10698 if (sym
->ts
.type
== BT_CHARACTER
)
10700 /* Make sure that character string variables with assumed length are
10701 dummy arguments. */
10702 e
= sym
->ts
.u
.cl
->length
;
10703 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
10704 && !sym
->ts
.deferred
)
10706 gfc_error ("Entity with assumed character length at %L must be a "
10707 "dummy argument or a PARAMETER", &sym
->declared_at
);
10711 if (e
&& sym
->attr
.save
== SAVE_EXPLICIT
&& !gfc_is_constant_expr (e
))
10713 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10717 if (!gfc_is_constant_expr (e
)
10718 && !(e
->expr_type
== EXPR_VARIABLE
10719 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
))
10721 if (!sym
->attr
.use_assoc
&& sym
->ns
->proc_name
10722 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
10723 || sym
->ns
->proc_name
->attr
.is_main_program
))
10725 gfc_error ("'%s' at %L must have constant character length "
10726 "in this context", sym
->name
, &sym
->declared_at
);
10729 if (sym
->attr
.in_common
)
10731 gfc_error ("COMMON variable '%s' at %L must have constant "
10732 "character length", sym
->name
, &sym
->declared_at
);
10738 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
10739 apply_default_init_local (sym
); /* Try to apply a default initialization. */
10741 /* Determine if the symbol may not have an initializer. */
10742 no_init_flag
= automatic_flag
= 0;
10743 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
10744 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
10746 else if ((sym
->attr
.dimension
|| sym
->attr
.codimension
) && !sym
->attr
.pointer
10747 && is_non_constant_shape_array (sym
))
10749 no_init_flag
= automatic_flag
= 1;
10751 /* Also, they must not have the SAVE attribute.
10752 SAVE_IMPLICIT is checked below. */
10753 if (sym
->as
&& sym
->attr
.codimension
)
10755 int corank
= sym
->as
->corank
;
10756 sym
->as
->corank
= 0;
10757 no_init_flag
= automatic_flag
= is_non_constant_shape_array (sym
);
10758 sym
->as
->corank
= corank
;
10760 if (automatic_flag
&& sym
->attr
.save
== SAVE_EXPLICIT
)
10762 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
10767 /* Ensure that any initializer is simplified. */
10769 gfc_simplify_expr (sym
->value
, 1);
10771 /* Reject illegal initializers. */
10772 if (!sym
->mark
&& sym
->value
)
10774 if (sym
->attr
.allocatable
|| (sym
->ts
.type
== BT_CLASS
10775 && CLASS_DATA (sym
)->attr
.allocatable
))
10776 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
10777 sym
->name
, &sym
->declared_at
);
10778 else if (sym
->attr
.external
)
10779 gfc_error ("External '%s' at %L cannot have an initializer",
10780 sym
->name
, &sym
->declared_at
);
10781 else if (sym
->attr
.dummy
10782 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
10783 gfc_error ("Dummy '%s' at %L cannot have an initializer",
10784 sym
->name
, &sym
->declared_at
);
10785 else if (sym
->attr
.intrinsic
)
10786 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
10787 sym
->name
, &sym
->declared_at
);
10788 else if (sym
->attr
.result
)
10789 gfc_error ("Function result '%s' at %L cannot have an initializer",
10790 sym
->name
, &sym
->declared_at
);
10791 else if (automatic_flag
)
10792 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
10793 sym
->name
, &sym
->declared_at
);
10795 goto no_init_error
;
10800 if (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
)
10801 return resolve_fl_variable_derived (sym
, no_init_flag
);
10807 /* Resolve a procedure. */
10810 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
10812 gfc_formal_arglist
*arg
;
10814 if (sym
->attr
.function
10815 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
10818 if (sym
->ts
.type
== BT_CHARACTER
)
10820 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
10822 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
10823 && resolve_charlen (cl
) == FAILURE
)
10826 if ((!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
10827 && sym
->attr
.proc
== PROC_ST_FUNCTION
)
10829 gfc_error ("Character-valued statement function '%s' at %L must "
10830 "have constant length", sym
->name
, &sym
->declared_at
);
10835 /* Ensure that derived type for are not of a private type. Internal
10836 module procedures are excluded by 2.2.3.3 - i.e., they are not
10837 externally accessible and can access all the objects accessible in
10839 if (!(sym
->ns
->parent
10840 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
10841 && gfc_check_symbol_access (sym
))
10843 gfc_interface
*iface
;
10845 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
10848 && arg
->sym
->ts
.type
== BT_DERIVED
10849 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10850 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10851 && gfc_notify_std (GFC_STD_F2003
, "'%s' is of a "
10852 "PRIVATE type and cannot be a dummy argument"
10853 " of '%s', which is PUBLIC at %L",
10854 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
10857 /* Stop this message from recurring. */
10858 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10863 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10864 PRIVATE to the containing module. */
10865 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10867 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10870 && arg
->sym
->ts
.type
== BT_DERIVED
10871 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10872 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10873 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
10874 "'%s' in PUBLIC interface '%s' at %L "
10875 "takes dummy arguments of '%s' which is "
10876 "PRIVATE", iface
->sym
->name
, sym
->name
,
10877 &iface
->sym
->declared_at
,
10878 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10880 /* Stop this message from recurring. */
10881 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10887 /* PUBLIC interfaces may expose PRIVATE procedures that take types
10888 PRIVATE to the containing module. */
10889 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
10891 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
10894 && arg
->sym
->ts
.type
== BT_DERIVED
10895 && !arg
->sym
->ts
.u
.derived
->attr
.use_assoc
10896 && !gfc_check_symbol_access (arg
->sym
->ts
.u
.derived
)
10897 && gfc_notify_std (GFC_STD_F2003
, "Procedure "
10898 "'%s' in PUBLIC interface '%s' at %L "
10899 "takes dummy arguments of '%s' which is "
10900 "PRIVATE", iface
->sym
->name
, sym
->name
,
10901 &iface
->sym
->declared_at
,
10902 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
10904 /* Stop this message from recurring. */
10905 arg
->sym
->ts
.u
.derived
->attr
.access
= ACCESS_PUBLIC
;
10912 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
10913 && !sym
->attr
.proc_pointer
)
10915 gfc_error ("Function '%s' at %L cannot have an initializer",
10916 sym
->name
, &sym
->declared_at
);
10920 /* An external symbol may not have an initializer because it is taken to be
10921 a procedure. Exception: Procedure Pointers. */
10922 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
10924 gfc_error ("External object '%s' at %L may not have an initializer",
10925 sym
->name
, &sym
->declared_at
);
10929 /* An elemental function is required to return a scalar 12.7.1 */
10930 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
10932 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
10933 "result", sym
->name
, &sym
->declared_at
);
10934 /* Reset so that the error only occurs once. */
10935 sym
->attr
.elemental
= 0;
10939 if (sym
->attr
.proc
== PROC_ST_FUNCTION
10940 && (sym
->attr
.allocatable
|| sym
->attr
.pointer
))
10942 gfc_error ("Statement function '%s' at %L may not have pointer or "
10943 "allocatable attribute", sym
->name
, &sym
->declared_at
);
10947 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
10948 char-len-param shall not be array-valued, pointer-valued, recursive
10949 or pure. ....snip... A character value of * may only be used in the
10950 following ways: (i) Dummy arg of procedure - dummy associates with
10951 actual length; (ii) To declare a named constant; or (iii) External
10952 function - but length must be declared in calling scoping unit. */
10953 if (sym
->attr
.function
10954 && sym
->ts
.type
== BT_CHARACTER
&& !sym
->ts
.deferred
10955 && sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
== NULL
)
10957 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
10958 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
10960 if (sym
->as
&& sym
->as
->rank
)
10961 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10962 "array-valued", sym
->name
, &sym
->declared_at
);
10964 if (sym
->attr
.pointer
)
10965 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10966 "pointer-valued", sym
->name
, &sym
->declared_at
);
10968 if (sym
->attr
.pure
)
10969 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10970 "pure", sym
->name
, &sym
->declared_at
);
10972 if (sym
->attr
.recursive
)
10973 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
10974 "recursive", sym
->name
, &sym
->declared_at
);
10979 /* Appendix B.2 of the standard. Contained functions give an
10980 error anyway. Fixed-form is likely to be F77/legacy. Deferred
10981 character length is an F2003 feature. */
10982 if (!sym
->attr
.contained
10983 && gfc_current_form
!= FORM_FIXED
10984 && !sym
->ts
.deferred
)
10985 gfc_notify_std (GFC_STD_F95_OBS
,
10986 "CHARACTER(*) function '%s' at %L",
10987 sym
->name
, &sym
->declared_at
);
10990 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
10992 gfc_formal_arglist
*curr_arg
;
10993 int has_non_interop_arg
= 0;
10995 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
10996 sym
->common_block
) == FAILURE
)
10998 /* Clear these to prevent looking at them again if there was an
11000 sym
->attr
.is_bind_c
= 0;
11001 sym
->attr
.is_c_interop
= 0;
11002 sym
->ts
.is_c_interop
= 0;
11006 /* So far, no errors have been found. */
11007 sym
->attr
.is_c_interop
= 1;
11008 sym
->ts
.is_c_interop
= 1;
11011 curr_arg
= sym
->formal
;
11012 while (curr_arg
!= NULL
)
11014 /* Skip implicitly typed dummy args here. */
11015 if (curr_arg
->sym
->attr
.implicit_type
== 0)
11016 if (gfc_verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
11017 /* If something is found to fail, record the fact so we
11018 can mark the symbol for the procedure as not being
11019 BIND(C) to try and prevent multiple errors being
11021 has_non_interop_arg
= 1;
11023 curr_arg
= curr_arg
->next
;
11026 /* See if any of the arguments were not interoperable and if so, clear
11027 the procedure symbol to prevent duplicate error messages. */
11028 if (has_non_interop_arg
!= 0)
11030 sym
->attr
.is_c_interop
= 0;
11031 sym
->ts
.is_c_interop
= 0;
11032 sym
->attr
.is_bind_c
= 0;
11036 if (!sym
->attr
.proc_pointer
)
11038 if (sym
->attr
.save
== SAVE_EXPLICIT
)
11040 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
11041 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11044 if (sym
->attr
.intent
)
11046 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
11047 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11050 if (sym
->attr
.subroutine
&& sym
->attr
.result
)
11052 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute "
11053 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11056 if (sym
->attr
.external
&& sym
->attr
.function
11057 && ((sym
->attr
.if_source
== IFSRC_DECL
&& !sym
->attr
.procedure
)
11058 || sym
->attr
.contained
))
11060 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute "
11061 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
11064 if (strcmp ("ppr@", sym
->name
) == 0)
11066 gfc_error ("Procedure pointer result '%s' at %L "
11067 "is missing the pointer attribute",
11068 sym
->ns
->proc_name
->name
, &sym
->declared_at
);
11077 /* Resolve a list of finalizer procedures. That is, after they have hopefully
11078 been defined and we now know their defined arguments, check that they fulfill
11079 the requirements of the standard for procedures used as finalizers. */
11082 gfc_resolve_finalizers (gfc_symbol
* derived
)
11084 gfc_finalizer
* list
;
11085 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
11086 gfc_try result
= SUCCESS
;
11087 bool seen_scalar
= false;
11089 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
11092 /* Walk over the list of finalizer-procedures, check them, and if any one
11093 does not fit in with the standard's definition, print an error and remove
11094 it from the list. */
11095 prev_link
= &derived
->f2k_derived
->finalizers
;
11096 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
11102 /* Skip this finalizer if we already resolved it. */
11103 if (list
->proc_tree
)
11105 prev_link
= &(list
->next
);
11109 /* Check this exists and is a SUBROUTINE. */
11110 if (!list
->proc_sym
->attr
.subroutine
)
11112 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
11113 list
->proc_sym
->name
, &list
->where
);
11117 /* We should have exactly one argument. */
11118 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
11120 gfc_error ("FINAL procedure at %L must have exactly one argument",
11124 arg
= list
->proc_sym
->formal
->sym
;
11126 /* This argument must be of our type. */
11127 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.u
.derived
!= derived
)
11129 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
11130 &arg
->declared_at
, derived
->name
);
11134 /* It must neither be a pointer nor allocatable nor optional. */
11135 if (arg
->attr
.pointer
)
11137 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
11138 &arg
->declared_at
);
11141 if (arg
->attr
.allocatable
)
11143 gfc_error ("Argument of FINAL procedure at %L must not be"
11144 " ALLOCATABLE", &arg
->declared_at
);
11147 if (arg
->attr
.optional
)
11149 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
11150 &arg
->declared_at
);
11154 /* It must not be INTENT(OUT). */
11155 if (arg
->attr
.intent
== INTENT_OUT
)
11157 gfc_error ("Argument of FINAL procedure at %L must not be"
11158 " INTENT(OUT)", &arg
->declared_at
);
11162 /* Warn if the procedure is non-scalar and not assumed shape. */
11163 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
!= 0
11164 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
11165 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
11166 " shape argument", &arg
->declared_at
);
11168 /* Check that it does not match in kind and rank with a FINAL procedure
11169 defined earlier. To really loop over the *earlier* declarations,
11170 we need to walk the tail of the list as new ones were pushed at the
11172 /* TODO: Handle kind parameters once they are implemented. */
11173 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
11174 for (i
= list
->next
; i
; i
= i
->next
)
11176 /* Argument list might be empty; that is an error signalled earlier,
11177 but we nevertheless continued resolving. */
11178 if (i
->proc_sym
->formal
)
11180 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
11181 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
11182 if (i_rank
== my_rank
)
11184 gfc_error ("FINAL procedure '%s' declared at %L has the same"
11185 " rank (%d) as '%s'",
11186 list
->proc_sym
->name
, &list
->where
, my_rank
,
11187 i
->proc_sym
->name
);
11193 /* Is this the/a scalar finalizer procedure? */
11194 if (!arg
->as
|| arg
->as
->rank
== 0)
11195 seen_scalar
= true;
11197 /* Find the symtree for this procedure. */
11198 gcc_assert (!list
->proc_tree
);
11199 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
11201 prev_link
= &list
->next
;
11204 /* Remove wrong nodes immediately from the list so we don't risk any
11205 troubles in the future when they might fail later expectations. */
11209 *prev_link
= list
->next
;
11210 gfc_free_finalizer (i
);
11213 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
11214 were nodes in the list, must have been for arrays. It is surely a good
11215 idea to have a scalar version there if there's something to finalize. */
11216 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
11217 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
11218 " defined at %L, suggest also scalar one",
11219 derived
->name
, &derived
->declared_at
);
11221 /* TODO: Remove this error when finalization is finished. */
11222 gfc_error ("Finalization at %L is not yet implemented",
11223 &derived
->declared_at
);
11225 gfc_find_derived_vtab (derived
);
11230 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
11233 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
11234 const char* generic_name
, locus where
)
11236 gfc_symbol
*sym1
, *sym2
;
11237 const char *pass1
, *pass2
;
11239 gcc_assert (t1
->specific
&& t2
->specific
);
11240 gcc_assert (!t1
->specific
->is_generic
);
11241 gcc_assert (!t2
->specific
->is_generic
);
11242 gcc_assert (t1
->is_operator
== t2
->is_operator
);
11244 sym1
= t1
->specific
->u
.specific
->n
.sym
;
11245 sym2
= t2
->specific
->u
.specific
->n
.sym
;
11250 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
11251 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
11252 || sym1
->attr
.function
!= sym2
->attr
.function
)
11254 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
11255 " GENERIC '%s' at %L",
11256 sym1
->name
, sym2
->name
, generic_name
, &where
);
11260 /* Compare the interfaces. */
11261 if (t1
->specific
->nopass
)
11263 else if (t1
->specific
->pass_arg
)
11264 pass1
= t1
->specific
->pass_arg
;
11266 pass1
= t1
->specific
->u
.specific
->n
.sym
->formal
->sym
->name
;
11267 if (t2
->specific
->nopass
)
11269 else if (t2
->specific
->pass_arg
)
11270 pass2
= t2
->specific
->pass_arg
;
11272 pass2
= t2
->specific
->u
.specific
->n
.sym
->formal
->sym
->name
;
11273 if (gfc_compare_interfaces (sym1
, sym2
, sym2
->name
, !t1
->is_operator
, 0,
11274 NULL
, 0, pass1
, pass2
))
11276 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
11277 sym1
->name
, sym2
->name
, generic_name
, &where
);
11285 /* Worker function for resolving a generic procedure binding; this is used to
11286 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
11288 The difference between those cases is finding possible inherited bindings
11289 that are overridden, as one has to look for them in tb_sym_root,
11290 tb_uop_root or tb_op, respectively. Thus the caller must already find
11291 the super-type and set p->overridden correctly. */
11294 resolve_tb_generic_targets (gfc_symbol
* super_type
,
11295 gfc_typebound_proc
* p
, const char* name
)
11297 gfc_tbp_generic
* target
;
11298 gfc_symtree
* first_target
;
11299 gfc_symtree
* inherited
;
11301 gcc_assert (p
&& p
->is_generic
);
11303 /* Try to find the specific bindings for the symtrees in our target-list. */
11304 gcc_assert (p
->u
.generic
);
11305 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11306 if (!target
->specific
)
11308 gfc_typebound_proc
* overridden_tbp
;
11309 gfc_tbp_generic
* g
;
11310 const char* target_name
;
11312 target_name
= target
->specific_st
->name
;
11314 /* Defined for this type directly. */
11315 if (target
->specific_st
->n
.tb
&& !target
->specific_st
->n
.tb
->error
)
11317 target
->specific
= target
->specific_st
->n
.tb
;
11318 goto specific_found
;
11321 /* Look for an inherited specific binding. */
11324 inherited
= gfc_find_typebound_proc (super_type
, NULL
, target_name
,
11329 gcc_assert (inherited
->n
.tb
);
11330 target
->specific
= inherited
->n
.tb
;
11331 goto specific_found
;
11335 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
11336 " at %L", target_name
, name
, &p
->where
);
11339 /* Once we've found the specific binding, check it is not ambiguous with
11340 other specifics already found or inherited for the same GENERIC. */
11342 gcc_assert (target
->specific
);
11344 /* This must really be a specific binding! */
11345 if (target
->specific
->is_generic
)
11347 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
11348 " '%s' is GENERIC, too", name
, &p
->where
, target_name
);
11352 /* Check those already resolved on this type directly. */
11353 for (g
= p
->u
.generic
; g
; g
= g
->next
)
11354 if (g
!= target
&& g
->specific
11355 && check_generic_tbp_ambiguity (target
, g
, name
, p
->where
)
11359 /* Check for ambiguity with inherited specific targets. */
11360 for (overridden_tbp
= p
->overridden
; overridden_tbp
;
11361 overridden_tbp
= overridden_tbp
->overridden
)
11362 if (overridden_tbp
->is_generic
)
11364 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
11366 gcc_assert (g
->specific
);
11367 if (check_generic_tbp_ambiguity (target
, g
,
11368 name
, p
->where
) == FAILURE
)
11374 /* If we attempt to "overwrite" a specific binding, this is an error. */
11375 if (p
->overridden
&& !p
->overridden
->is_generic
)
11377 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
11378 " the same name", name
, &p
->where
);
11382 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
11383 all must have the same attributes here. */
11384 first_target
= p
->u
.generic
->specific
->u
.specific
;
11385 gcc_assert (first_target
);
11386 p
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
11387 p
->function
= first_target
->n
.sym
->attr
.function
;
11393 /* Resolve a GENERIC procedure binding for a derived type. */
11396 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
11398 gfc_symbol
* super_type
;
11400 /* Find the overridden binding if any. */
11401 st
->n
.tb
->overridden
= NULL
;
11402 super_type
= gfc_get_derived_super_type (derived
);
11405 gfc_symtree
* overridden
;
11406 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
,
11409 if (overridden
&& overridden
->n
.tb
)
11410 st
->n
.tb
->overridden
= overridden
->n
.tb
;
11413 /* Resolve using worker function. */
11414 return resolve_tb_generic_targets (super_type
, st
->n
.tb
, st
->name
);
11418 /* Retrieve the target-procedure of an operator binding and do some checks in
11419 common for intrinsic and user-defined type-bound operators. */
11422 get_checked_tb_operator_target (gfc_tbp_generic
* target
, locus where
)
11424 gfc_symbol
* target_proc
;
11426 gcc_assert (target
->specific
&& !target
->specific
->is_generic
);
11427 target_proc
= target
->specific
->u
.specific
->n
.sym
;
11428 gcc_assert (target_proc
);
11430 /* All operator bindings must have a passed-object dummy argument. */
11431 if (target
->specific
->nopass
)
11433 gfc_error ("Type-bound operator at %L can't be NOPASS", &where
);
11437 return target_proc
;
11441 /* Resolve a type-bound intrinsic operator. */
11444 resolve_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_intrinsic_op op
,
11445 gfc_typebound_proc
* p
)
11447 gfc_symbol
* super_type
;
11448 gfc_tbp_generic
* target
;
11450 /* If there's already an error here, do nothing (but don't fail again). */
11454 /* Operators should always be GENERIC bindings. */
11455 gcc_assert (p
->is_generic
);
11457 /* Look for an overridden binding. */
11458 super_type
= gfc_get_derived_super_type (derived
);
11459 if (super_type
&& super_type
->f2k_derived
)
11460 p
->overridden
= gfc_find_typebound_intrinsic_op (super_type
, NULL
,
11463 p
->overridden
= NULL
;
11465 /* Resolve general GENERIC properties using worker function. */
11466 if (resolve_tb_generic_targets (super_type
, p
, gfc_op2string (op
)) == FAILURE
)
11469 /* Check the targets to be procedures of correct interface. */
11470 for (target
= p
->u
.generic
; target
; target
= target
->next
)
11472 gfc_symbol
* target_proc
;
11474 target_proc
= get_checked_tb_operator_target (target
, p
->where
);
11478 if (!gfc_check_operator_interface (target_proc
, op
, p
->where
))
11481 /* Add target to non-typebound operator list. */
11482 if (!target
->specific
->deferred
&& !derived
->attr
.use_assoc
11483 && p
->access
!= ACCESS_PRIVATE
)
11485 gfc_interface
*head
, *intr
;
11486 if (gfc_check_new_interface (derived
->ns
->op
[op
], target_proc
,
11487 p
->where
) == FAILURE
)
11489 head
= derived
->ns
->op
[op
];
11490 intr
= gfc_get_interface ();
11491 intr
->sym
= target_proc
;
11492 intr
->where
= p
->where
;
11494 derived
->ns
->op
[op
] = intr
;
11506 /* Resolve a type-bound user operator (tree-walker callback). */
11508 static gfc_symbol
* resolve_bindings_derived
;
11509 static gfc_try resolve_bindings_result
;
11511 static gfc_try
check_uop_procedure (gfc_symbol
* sym
, locus where
);
11514 resolve_typebound_user_op (gfc_symtree
* stree
)
11516 gfc_symbol
* super_type
;
11517 gfc_tbp_generic
* target
;
11519 gcc_assert (stree
&& stree
->n
.tb
);
11521 if (stree
->n
.tb
->error
)
11524 /* Operators should always be GENERIC bindings. */
11525 gcc_assert (stree
->n
.tb
->is_generic
);
11527 /* Find overridden procedure, if any. */
11528 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11529 if (super_type
&& super_type
->f2k_derived
)
11531 gfc_symtree
* overridden
;
11532 overridden
= gfc_find_typebound_user_op (super_type
, NULL
,
11533 stree
->name
, true, NULL
);
11535 if (overridden
&& overridden
->n
.tb
)
11536 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11539 stree
->n
.tb
->overridden
= NULL
;
11541 /* Resolve basically using worker function. */
11542 if (resolve_tb_generic_targets (super_type
, stree
->n
.tb
, stree
->name
)
11546 /* Check the targets to be functions of correct interface. */
11547 for (target
= stree
->n
.tb
->u
.generic
; target
; target
= target
->next
)
11549 gfc_symbol
* target_proc
;
11551 target_proc
= get_checked_tb_operator_target (target
, stree
->n
.tb
->where
);
11555 if (check_uop_procedure (target_proc
, stree
->n
.tb
->where
) == FAILURE
)
11562 resolve_bindings_result
= FAILURE
;
11563 stree
->n
.tb
->error
= 1;
11567 /* Resolve the type-bound procedures for a derived type. */
11570 resolve_typebound_procedure (gfc_symtree
* stree
)
11574 gfc_symbol
* me_arg
;
11575 gfc_symbol
* super_type
;
11576 gfc_component
* comp
;
11578 gcc_assert (stree
);
11580 /* Undefined specific symbol from GENERIC target definition. */
11584 if (stree
->n
.tb
->error
)
11587 /* If this is a GENERIC binding, use that routine. */
11588 if (stree
->n
.tb
->is_generic
)
11590 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
11596 /* Get the target-procedure to check it. */
11597 gcc_assert (!stree
->n
.tb
->is_generic
);
11598 gcc_assert (stree
->n
.tb
->u
.specific
);
11599 proc
= stree
->n
.tb
->u
.specific
->n
.sym
;
11600 where
= stree
->n
.tb
->where
;
11601 proc
->attr
.public_used
= 1;
11603 /* Default access should already be resolved from the parser. */
11604 gcc_assert (stree
->n
.tb
->access
!= ACCESS_UNKNOWN
);
11606 if (stree
->n
.tb
->deferred
)
11608 if (check_proc_interface (proc
, &where
) == FAILURE
)
11613 /* Check for F08:C465. */
11614 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
11615 || (proc
->attr
.proc
!= PROC_MODULE
11616 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
11617 || proc
->attr
.abstract
)
11619 gfc_error ("'%s' must be a module procedure or an external procedure with"
11620 " an explicit interface at %L", proc
->name
, &where
);
11625 stree
->n
.tb
->subroutine
= proc
->attr
.subroutine
;
11626 stree
->n
.tb
->function
= proc
->attr
.function
;
11628 /* Find the super-type of the current derived type. We could do this once and
11629 store in a global if speed is needed, but as long as not I believe this is
11630 more readable and clearer. */
11631 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
11633 /* If PASS, resolve and check arguments if not already resolved / loaded
11634 from a .mod file. */
11635 if (!stree
->n
.tb
->nopass
&& stree
->n
.tb
->pass_arg_num
== 0)
11637 if (stree
->n
.tb
->pass_arg
)
11639 gfc_formal_arglist
* i
;
11641 /* If an explicit passing argument name is given, walk the arg-list
11642 and look for it. */
11645 stree
->n
.tb
->pass_arg_num
= 1;
11646 for (i
= proc
->formal
; i
; i
= i
->next
)
11648 if (!strcmp (i
->sym
->name
, stree
->n
.tb
->pass_arg
))
11653 ++stree
->n
.tb
->pass_arg_num
;
11658 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
11660 proc
->name
, stree
->n
.tb
->pass_arg
, &where
,
11661 stree
->n
.tb
->pass_arg
);
11667 /* Otherwise, take the first one; there should in fact be at least
11669 stree
->n
.tb
->pass_arg_num
= 1;
11672 gfc_error ("Procedure '%s' with PASS at %L must have at"
11673 " least one argument", proc
->name
, &where
);
11676 me_arg
= proc
->formal
->sym
;
11679 /* Now check that the argument-type matches and the passed-object
11680 dummy argument is generally fine. */
11682 gcc_assert (me_arg
);
11684 if (me_arg
->ts
.type
!= BT_CLASS
)
11686 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
11687 " at %L", proc
->name
, &where
);
11691 if (CLASS_DATA (me_arg
)->ts
.u
.derived
11692 != resolve_bindings_derived
)
11694 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
11695 " the derived-type '%s'", me_arg
->name
, proc
->name
,
11696 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
11700 gcc_assert (me_arg
->ts
.type
== BT_CLASS
);
11701 if (CLASS_DATA (me_arg
)->as
&& CLASS_DATA (me_arg
)->as
->rank
!= 0)
11703 gfc_error ("Passed-object dummy argument of '%s' at %L must be"
11704 " scalar", proc
->name
, &where
);
11707 if (CLASS_DATA (me_arg
)->attr
.allocatable
)
11709 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11710 " be ALLOCATABLE", proc
->name
, &where
);
11713 if (CLASS_DATA (me_arg
)->attr
.class_pointer
)
11715 gfc_error ("Passed-object dummy argument of '%s' at %L must not"
11716 " be POINTER", proc
->name
, &where
);
11721 /* If we are extending some type, check that we don't override a procedure
11722 flagged NON_OVERRIDABLE. */
11723 stree
->n
.tb
->overridden
= NULL
;
11726 gfc_symtree
* overridden
;
11727 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
11728 stree
->name
, true, NULL
);
11732 if (overridden
->n
.tb
)
11733 stree
->n
.tb
->overridden
= overridden
->n
.tb
;
11735 if (gfc_check_typebound_override (stree
, overridden
) == FAILURE
)
11740 /* See if there's a name collision with a component directly in this type. */
11741 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
11742 if (!strcmp (comp
->name
, stree
->name
))
11744 gfc_error ("Procedure '%s' at %L has the same name as a component of"
11746 stree
->name
, &where
, resolve_bindings_derived
->name
);
11750 /* Try to find a name collision with an inherited component. */
11751 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
11753 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
11754 " component of '%s'",
11755 stree
->name
, &where
, resolve_bindings_derived
->name
);
11759 stree
->n
.tb
->error
= 0;
11763 resolve_bindings_result
= FAILURE
;
11764 stree
->n
.tb
->error
= 1;
11769 resolve_typebound_procedures (gfc_symbol
* derived
)
11772 gfc_symbol
* super_type
;
11774 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->tb_sym_root
)
11777 super_type
= gfc_get_derived_super_type (derived
);
11779 resolve_typebound_procedures (super_type
);
11781 resolve_bindings_derived
= derived
;
11782 resolve_bindings_result
= SUCCESS
;
11784 /* Make sure the vtab has been generated. */
11785 gfc_find_derived_vtab (derived
);
11787 if (derived
->f2k_derived
->tb_sym_root
)
11788 gfc_traverse_symtree (derived
->f2k_derived
->tb_sym_root
,
11789 &resolve_typebound_procedure
);
11791 if (derived
->f2k_derived
->tb_uop_root
)
11792 gfc_traverse_symtree (derived
->f2k_derived
->tb_uop_root
,
11793 &resolve_typebound_user_op
);
11795 for (op
= 0; op
!= GFC_INTRINSIC_OPS
; ++op
)
11797 gfc_typebound_proc
* p
= derived
->f2k_derived
->tb_op
[op
];
11798 if (p
&& resolve_typebound_intrinsic_op (derived
, (gfc_intrinsic_op
) op
,
11800 resolve_bindings_result
= FAILURE
;
11803 return resolve_bindings_result
;
11807 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
11808 to give all identical derived types the same backend_decl. */
11810 add_dt_to_dt_list (gfc_symbol
*derived
)
11812 gfc_dt_list
*dt_list
;
11814 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
11815 if (derived
== dt_list
->derived
)
11818 dt_list
= gfc_get_dt_list ();
11819 dt_list
->next
= gfc_derived_types
;
11820 dt_list
->derived
= derived
;
11821 gfc_derived_types
= dt_list
;
11825 /* Ensure that a derived-type is really not abstract, meaning that every
11826 inherited DEFERRED binding is overridden by a non-DEFERRED one. */
11829 ensure_not_abstract_walker (gfc_symbol
* sub
, gfc_symtree
* st
)
11834 if (ensure_not_abstract_walker (sub
, st
->left
) == FAILURE
)
11836 if (ensure_not_abstract_walker (sub
, st
->right
) == FAILURE
)
11839 if (st
->n
.tb
&& st
->n
.tb
->deferred
)
11841 gfc_symtree
* overriding
;
11842 overriding
= gfc_find_typebound_proc (sub
, NULL
, st
->name
, true, NULL
);
11845 gcc_assert (overriding
->n
.tb
);
11846 if (overriding
->n
.tb
->deferred
)
11848 gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
11849 " '%s' is DEFERRED and not overridden",
11850 sub
->name
, &sub
->declared_at
, st
->name
);
11859 ensure_not_abstract (gfc_symbol
* sub
, gfc_symbol
* ancestor
)
11861 /* The algorithm used here is to recursively travel up the ancestry of sub
11862 and for each ancestor-type, check all bindings. If any of them is
11863 DEFERRED, look it up starting from sub and see if the found (overriding)
11864 binding is not DEFERRED.
11865 This is not the most efficient way to do this, but it should be ok and is
11866 clearer than something sophisticated. */
11868 gcc_assert (ancestor
&& !sub
->attr
.abstract
);
11870 if (!ancestor
->attr
.abstract
)
11873 /* Walk bindings of this ancestor. */
11874 if (ancestor
->f2k_derived
)
11877 t
= ensure_not_abstract_walker (sub
, ancestor
->f2k_derived
->tb_sym_root
);
11882 /* Find next ancestor type and recurse on it. */
11883 ancestor
= gfc_get_derived_super_type (ancestor
);
11885 return ensure_not_abstract (sub
, ancestor
);
11891 /* Resolve the components of a derived type. This does not have to wait until
11892 resolution stage, but can be done as soon as the dt declaration has been
11896 resolve_fl_derived0 (gfc_symbol
*sym
)
11898 gfc_symbol
* super_type
;
11901 super_type
= gfc_get_derived_super_type (sym
);
11904 if (super_type
&& sym
->attr
.coarray_comp
&& !super_type
->attr
.coarray_comp
)
11906 gfc_error ("As extending type '%s' at %L has a coarray component, "
11907 "parent type '%s' shall also have one", sym
->name
,
11908 &sym
->declared_at
, super_type
->name
);
11912 /* Ensure the extended type gets resolved before we do. */
11913 if (super_type
&& resolve_fl_derived0 (super_type
) == FAILURE
)
11916 /* An ABSTRACT type must be extensible. */
11917 if (sym
->attr
.abstract
&& !gfc_type_is_extensible (sym
))
11919 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
11920 sym
->name
, &sym
->declared_at
);
11924 c
= (sym
->attr
.is_class
) ? sym
->components
->ts
.u
.derived
->components
11927 for ( ; c
!= NULL
; c
= c
->next
)
11929 if (c
->attr
.artificial
)
11932 /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170. */
11933 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
&& !c
->attr
.function
)
11935 gfc_error ("Deferred-length character component '%s' at %L is not "
11936 "yet supported", c
->name
, &c
->loc
);
11941 if ((!sym
->attr
.is_class
|| c
!= sym
->components
)
11942 && c
->attr
.codimension
11943 && (!c
->attr
.allocatable
|| (c
->as
&& c
->as
->type
!= AS_DEFERRED
)))
11945 gfc_error ("Coarray component '%s' at %L must be allocatable with "
11946 "deferred shape", c
->name
, &c
->loc
);
11951 if (c
->attr
.codimension
&& c
->ts
.type
== BT_DERIVED
11952 && c
->ts
.u
.derived
->ts
.is_iso_c
)
11954 gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
11955 "shall not be a coarray", c
->name
, &c
->loc
);
11960 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
11961 && (c
->attr
.codimension
|| c
->attr
.pointer
|| c
->attr
.dimension
11962 || c
->attr
.allocatable
))
11964 gfc_error ("Component '%s' at %L with coarray component "
11965 "shall be a nonpointer, nonallocatable scalar",
11971 if (c
->attr
.contiguous
&& (!c
->attr
.dimension
|| !c
->attr
.pointer
))
11973 gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but "
11974 "is not an array pointer", c
->name
, &c
->loc
);
11978 if (c
->attr
.proc_pointer
&& c
->ts
.interface
)
11980 gfc_symbol
*ifc
= c
->ts
.interface
;
11982 if (!sym
->attr
.vtype
11983 && check_proc_interface (ifc
, &c
->loc
) == FAILURE
)
11986 if (ifc
->attr
.if_source
|| ifc
->attr
.intrinsic
)
11988 /* Resolve interface and copy attributes. */
11989 if (ifc
->formal
&& !ifc
->formal_ns
)
11990 resolve_symbol (ifc
);
11991 if (ifc
->attr
.intrinsic
)
11992 gfc_resolve_intrinsic (ifc
, &ifc
->declared_at
);
11996 c
->ts
= ifc
->result
->ts
;
11997 c
->attr
.allocatable
= ifc
->result
->attr
.allocatable
;
11998 c
->attr
.pointer
= ifc
->result
->attr
.pointer
;
11999 c
->attr
.dimension
= ifc
->result
->attr
.dimension
;
12000 c
->as
= gfc_copy_array_spec (ifc
->result
->as
);
12005 c
->attr
.allocatable
= ifc
->attr
.allocatable
;
12006 c
->attr
.pointer
= ifc
->attr
.pointer
;
12007 c
->attr
.dimension
= ifc
->attr
.dimension
;
12008 c
->as
= gfc_copy_array_spec (ifc
->as
);
12010 c
->ts
.interface
= ifc
;
12011 c
->attr
.function
= ifc
->attr
.function
;
12012 c
->attr
.subroutine
= ifc
->attr
.subroutine
;
12013 gfc_copy_formal_args_ppc (c
, ifc
, IFSRC_DECL
);
12015 c
->attr
.pure
= ifc
->attr
.pure
;
12016 c
->attr
.elemental
= ifc
->attr
.elemental
;
12017 c
->attr
.recursive
= ifc
->attr
.recursive
;
12018 c
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
12019 c
->attr
.ext_attr
|= ifc
->attr
.ext_attr
;
12020 c
->attr
.class_ok
= ifc
->attr
.class_ok
;
12021 /* Replace symbols in array spec. */
12025 for (i
= 0; i
< c
->as
->rank
; i
++)
12027 gfc_expr_replace_comp (c
->as
->lower
[i
], c
);
12028 gfc_expr_replace_comp (c
->as
->upper
[i
], c
);
12031 /* Copy char length. */
12032 if (ifc
->ts
.type
== BT_CHARACTER
&& ifc
->ts
.u
.cl
)
12034 gfc_charlen
*cl
= gfc_new_charlen (sym
->ns
, ifc
->ts
.u
.cl
);
12035 gfc_expr_replace_comp (cl
->length
, c
);
12036 if (cl
->length
&& !cl
->resolved
12037 && gfc_resolve_expr (cl
->length
) == FAILURE
)
12043 else if (c
->attr
.proc_pointer
&& c
->ts
.type
== BT_UNKNOWN
)
12045 /* Since PPCs are not implicitly typed, a PPC without an explicit
12046 interface must be a subroutine. */
12047 gfc_add_subroutine (&c
->attr
, c
->name
, &c
->loc
);
12050 /* Procedure pointer components: Check PASS arg. */
12051 if (c
->attr
.proc_pointer
&& !c
->tb
->nopass
&& c
->tb
->pass_arg_num
== 0
12052 && !sym
->attr
.vtype
)
12054 gfc_symbol
* me_arg
;
12056 if (c
->tb
->pass_arg
)
12058 gfc_formal_arglist
* i
;
12060 /* If an explicit passing argument name is given, walk the arg-list
12061 and look for it. */
12064 c
->tb
->pass_arg_num
= 1;
12065 for (i
= c
->formal
; i
; i
= i
->next
)
12067 if (!strcmp (i
->sym
->name
, c
->tb
->pass_arg
))
12072 c
->tb
->pass_arg_num
++;
12077 gfc_error ("Procedure pointer component '%s' with PASS(%s) "
12078 "at %L has no argument '%s'", c
->name
,
12079 c
->tb
->pass_arg
, &c
->loc
, c
->tb
->pass_arg
);
12086 /* Otherwise, take the first one; there should in fact be at least
12088 c
->tb
->pass_arg_num
= 1;
12091 gfc_error ("Procedure pointer component '%s' with PASS at %L "
12092 "must have at least one argument",
12097 me_arg
= c
->formal
->sym
;
12100 /* Now check that the argument-type matches. */
12101 gcc_assert (me_arg
);
12102 if ((me_arg
->ts
.type
!= BT_DERIVED
&& me_arg
->ts
.type
!= BT_CLASS
)
12103 || (me_arg
->ts
.type
== BT_DERIVED
&& me_arg
->ts
.u
.derived
!= sym
)
12104 || (me_arg
->ts
.type
== BT_CLASS
12105 && CLASS_DATA (me_arg
)->ts
.u
.derived
!= sym
))
12107 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
12108 " the derived type '%s'", me_arg
->name
, c
->name
,
12109 me_arg
->name
, &c
->loc
, sym
->name
);
12114 /* Check for C453. */
12115 if (me_arg
->attr
.dimension
)
12117 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12118 "must be scalar", me_arg
->name
, c
->name
, me_arg
->name
,
12124 if (me_arg
->attr
.pointer
)
12126 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12127 "may not have the POINTER attribute", me_arg
->name
,
12128 c
->name
, me_arg
->name
, &c
->loc
);
12133 if (me_arg
->attr
.allocatable
)
12135 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
12136 "may not be ALLOCATABLE", me_arg
->name
, c
->name
,
12137 me_arg
->name
, &c
->loc
);
12142 if (gfc_type_is_extensible (sym
) && me_arg
->ts
.type
!= BT_CLASS
)
12143 gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
12144 " at %L", c
->name
, &c
->loc
);
12148 /* Check type-spec if this is not the parent-type component. */
12149 if (((sym
->attr
.is_class
12150 && (!sym
->components
->ts
.u
.derived
->attr
.extension
12151 || c
!= sym
->components
->ts
.u
.derived
->components
))
12152 || (!sym
->attr
.is_class
12153 && (!sym
->attr
.extension
|| c
!= sym
->components
)))
12154 && !sym
->attr
.vtype
12155 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
12158 /* If this type is an extension, set the accessibility of the parent
12161 && ((sym
->attr
.is_class
12162 && c
== sym
->components
->ts
.u
.derived
->components
)
12163 || (!sym
->attr
.is_class
&& c
== sym
->components
))
12164 && strcmp (super_type
->name
, c
->name
) == 0)
12165 c
->attr
.access
= super_type
->attr
.access
;
12167 /* If this type is an extension, see if this component has the same name
12168 as an inherited type-bound procedure. */
12169 if (super_type
&& !sym
->attr
.is_class
12170 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true, NULL
))
12172 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
12173 " inherited type-bound procedure",
12174 c
->name
, sym
->name
, &c
->loc
);
12178 if (c
->ts
.type
== BT_CHARACTER
&& !c
->attr
.proc_pointer
12179 && !c
->ts
.deferred
)
12181 if (c
->ts
.u
.cl
->length
== NULL
12182 || (resolve_charlen (c
->ts
.u
.cl
) == FAILURE
)
12183 || !gfc_is_constant_expr (c
->ts
.u
.cl
->length
))
12185 gfc_error ("Character length of component '%s' needs to "
12186 "be a constant specification expression at %L",
12188 c
->ts
.u
.cl
->length
? &c
->ts
.u
.cl
->length
->where
: &c
->loc
);
12193 if (c
->ts
.type
== BT_CHARACTER
&& c
->ts
.deferred
12194 && !c
->attr
.pointer
&& !c
->attr
.allocatable
)
12196 gfc_error ("Character component '%s' of '%s' at %L with deferred "
12197 "length must be a POINTER or ALLOCATABLE",
12198 c
->name
, sym
->name
, &c
->loc
);
12202 if (c
->ts
.type
== BT_DERIVED
12203 && sym
->component_access
!= ACCESS_PRIVATE
12204 && gfc_check_symbol_access (sym
)
12205 && !is_sym_host_assoc (c
->ts
.u
.derived
, sym
->ns
)
12206 && !c
->ts
.u
.derived
->attr
.use_assoc
12207 && !gfc_check_symbol_access (c
->ts
.u
.derived
)
12208 && gfc_notify_std (GFC_STD_F2003
, "the component '%s' "
12209 "is a PRIVATE type and cannot be a component of "
12210 "'%s', which is PUBLIC at %L", c
->name
,
12211 sym
->name
, &sym
->declared_at
) == FAILURE
)
12214 if ((sym
->attr
.sequence
|| sym
->attr
.is_bind_c
) && c
->ts
.type
== BT_CLASS
)
12216 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
12217 "type %s", c
->name
, &c
->loc
, sym
->name
);
12221 if (sym
->attr
.sequence
)
12223 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.sequence
== 0)
12225 gfc_error ("Component %s of SEQUENCE type declared at %L does "
12226 "not have the SEQUENCE attribute",
12227 c
->ts
.u
.derived
->name
, &sym
->declared_at
);
12232 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.generic
)
12233 c
->ts
.u
.derived
= gfc_find_dt_in_generic (c
->ts
.u
.derived
);
12234 else if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12235 && CLASS_DATA (c
)->ts
.u
.derived
->attr
.generic
)
12236 CLASS_DATA (c
)->ts
.u
.derived
12237 = gfc_find_dt_in_generic (CLASS_DATA (c
)->ts
.u
.derived
);
12239 if (!sym
->attr
.is_class
&& c
->ts
.type
== BT_DERIVED
&& !sym
->attr
.vtype
12240 && c
->attr
.pointer
&& c
->ts
.u
.derived
->components
== NULL
12241 && !c
->ts
.u
.derived
->attr
.zero_comp
)
12243 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12244 "that has not been declared", c
->name
, sym
->name
,
12249 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
12250 && CLASS_DATA (c
)->attr
.class_pointer
12251 && CLASS_DATA (c
)->ts
.u
.derived
->components
== NULL
12252 && !CLASS_DATA (c
)->ts
.u
.derived
->attr
.zero_comp
)
12254 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
12255 "that has not been declared", c
->name
, sym
->name
,
12261 if (c
->ts
.type
== BT_CLASS
&& c
->attr
.flavor
!= FL_PROCEDURE
12262 && (!c
->attr
.class_ok
12263 || !(CLASS_DATA (c
)->attr
.class_pointer
12264 || CLASS_DATA (c
)->attr
.allocatable
)))
12266 gfc_error ("Component '%s' with CLASS at %L must be allocatable "
12267 "or pointer", c
->name
, &c
->loc
);
12271 /* Ensure that all the derived type components are put on the
12272 derived type list; even in formal namespaces, where derived type
12273 pointer components might not have been declared. */
12274 if (c
->ts
.type
== BT_DERIVED
12276 && c
->ts
.u
.derived
->components
12278 && sym
!= c
->ts
.u
.derived
)
12279 add_dt_to_dt_list (c
->ts
.u
.derived
);
12281 if (gfc_resolve_array_spec (c
->as
, !(c
->attr
.pointer
12282 || c
->attr
.proc_pointer
12283 || c
->attr
.allocatable
)) == FAILURE
)
12287 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
12288 all DEFERRED bindings are overridden. */
12289 if (super_type
&& super_type
->attr
.abstract
&& !sym
->attr
.abstract
12290 && !sym
->attr
.is_class
12291 && ensure_not_abstract (sym
, super_type
) == FAILURE
)
12294 /* Add derived type to the derived type list. */
12295 add_dt_to_dt_list (sym
);
12301 /* The following procedure does the full resolution of a derived type,
12302 including resolution of all type-bound procedures (if present). In contrast
12303 to 'resolve_fl_derived0' this can only be done after the module has been
12304 parsed completely. */
12307 resolve_fl_derived (gfc_symbol
*sym
)
12309 gfc_symbol
*gen_dt
= NULL
;
12311 if (!sym
->attr
.is_class
)
12312 gfc_find_symbol (sym
->name
, sym
->ns
, 0, &gen_dt
);
12313 if (gen_dt
&& gen_dt
->generic
&& gen_dt
->generic
->next
12314 && (!gen_dt
->generic
->sym
->attr
.use_assoc
12315 || gen_dt
->generic
->sym
->module
!= gen_dt
->generic
->next
->sym
->module
)
12316 && gfc_notify_std (GFC_STD_F2003
, "Generic name '%s' of "
12317 "function '%s' at %L being the same name as derived "
12318 "type at %L", sym
->name
,
12319 gen_dt
->generic
->sym
== sym
12320 ? gen_dt
->generic
->next
->sym
->name
12321 : gen_dt
->generic
->sym
->name
,
12322 gen_dt
->generic
->sym
== sym
12323 ? &gen_dt
->generic
->next
->sym
->declared_at
12324 : &gen_dt
->generic
->sym
->declared_at
,
12325 &sym
->declared_at
) == FAILURE
)
12328 /* Resolve the finalizer procedures. */
12329 if (gfc_resolve_finalizers (sym
) == FAILURE
)
12332 if (sym
->attr
.is_class
&& sym
->ts
.u
.derived
== NULL
)
12334 /* Fix up incomplete CLASS symbols. */
12335 gfc_component
*data
= gfc_find_component (sym
, "_data", true, true);
12336 gfc_component
*vptr
= gfc_find_component (sym
, "_vptr", true, true);
12337 if (vptr
->ts
.u
.derived
== NULL
)
12339 gfc_symbol
*vtab
= gfc_find_derived_vtab (data
->ts
.u
.derived
);
12341 vptr
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
12345 if (resolve_fl_derived0 (sym
) == FAILURE
)
12348 /* Resolve the type-bound procedures. */
12349 if (resolve_typebound_procedures (sym
) == FAILURE
)
12357 resolve_fl_namelist (gfc_symbol
*sym
)
12362 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12364 /* Check again, the check in match only works if NAMELIST comes
12366 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SIZE
)
12368 gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
12369 "allowed", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12373 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
12374 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
12375 "object '%s' with assumed shape in namelist "
12376 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12377 &sym
->declared_at
) == FAILURE
)
12380 if (is_non_constant_shape_array (nl
->sym
)
12381 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array "
12382 "object '%s' with nonconstant shape in namelist "
12383 "'%s' at %L", nl
->sym
->name
, sym
->name
,
12384 &sym
->declared_at
) == FAILURE
)
12387 if (nl
->sym
->ts
.type
== BT_CHARACTER
12388 && (nl
->sym
->ts
.u
.cl
->length
== NULL
12389 || !gfc_is_constant_expr (nl
->sym
->ts
.u
.cl
->length
))
12390 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
12391 "'%s' with nonconstant character length in "
12392 "namelist '%s' at %L", nl
->sym
->name
, sym
->name
,
12393 &sym
->declared_at
) == FAILURE
)
12396 /* FIXME: Once UDDTIO is implemented, the following can be
12398 if (nl
->sym
->ts
.type
== BT_CLASS
)
12400 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
12401 "polymorphic and requires a defined input/output "
12402 "procedure", nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12406 if (nl
->sym
->ts
.type
== BT_DERIVED
12407 && (nl
->sym
->ts
.u
.derived
->attr
.alloc_comp
12408 || nl
->sym
->ts
.u
.derived
->attr
.pointer_comp
))
12410 if (gfc_notify_std (GFC_STD_F2003
, "NAMELIST object "
12411 "'%s' in namelist '%s' at %L with ALLOCATABLE "
12412 "or POINTER components", nl
->sym
->name
,
12413 sym
->name
, &sym
->declared_at
) == FAILURE
)
12416 /* FIXME: Once UDDTIO is implemented, the following can be
12418 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
12419 "ALLOCATABLE or POINTER components and thus requires "
12420 "a defined input/output procedure", nl
->sym
->name
,
12421 sym
->name
, &sym
->declared_at
);
12426 /* Reject PRIVATE objects in a PUBLIC namelist. */
12427 if (gfc_check_symbol_access (sym
))
12429 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12431 if (!nl
->sym
->attr
.use_assoc
12432 && !is_sym_host_assoc (nl
->sym
, sym
->ns
)
12433 && !gfc_check_symbol_access (nl
->sym
))
12435 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
12436 "cannot be member of PUBLIC namelist '%s' at %L",
12437 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12441 /* Types with private components that came here by USE-association. */
12442 if (nl
->sym
->ts
.type
== BT_DERIVED
12443 && derived_inaccessible (nl
->sym
->ts
.u
.derived
))
12445 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
12446 "components and cannot be member of namelist '%s' at %L",
12447 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12451 /* Types with private components that are defined in the same module. */
12452 if (nl
->sym
->ts
.type
== BT_DERIVED
12453 && !is_sym_host_assoc (nl
->sym
->ts
.u
.derived
, sym
->ns
)
12454 && nl
->sym
->ts
.u
.derived
->attr
.private_comp
)
12456 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
12457 "cannot be a member of PUBLIC namelist '%s' at %L",
12458 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
12465 /* 14.1.2 A module or internal procedure represent local entities
12466 of the same type as a namelist member and so are not allowed. */
12467 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
12469 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
12472 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
12473 if ((nl
->sym
== sym
->ns
->proc_name
)
12475 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
12479 if (nl
->sym
&& nl
->sym
->name
)
12480 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
12481 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
12483 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
12484 "attribute in '%s' at %L", nlsym
->name
,
12485 &sym
->declared_at
);
12495 resolve_fl_parameter (gfc_symbol
*sym
)
12497 /* A parameter array's shape needs to be constant. */
12498 if (sym
->as
!= NULL
12499 && (sym
->as
->type
== AS_DEFERRED
12500 || is_non_constant_shape_array (sym
)))
12502 gfc_error ("Parameter array '%s' at %L cannot be automatic "
12503 "or of deferred shape", sym
->name
, &sym
->declared_at
);
12507 /* Make sure a parameter that has been implicitly typed still
12508 matches the implicit type, since PARAMETER statements can precede
12509 IMPLICIT statements. */
12510 if (sym
->attr
.implicit_type
12511 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
->name
,
12514 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
12515 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
12519 /* Make sure the types of derived parameters are consistent. This
12520 type checking is deferred until resolution because the type may
12521 refer to a derived type from the host. */
12522 if (sym
->ts
.type
== BT_DERIVED
12523 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
12525 gfc_error ("Incompatible derived type in PARAMETER at %L",
12526 &sym
->value
->where
);
12533 /* Do anything necessary to resolve a symbol. Right now, we just
12534 assume that an otherwise unknown symbol is a variable. This sort
12535 of thing commonly happens for symbols in module. */
12538 resolve_symbol (gfc_symbol
*sym
)
12540 int check_constant
, mp_flag
;
12541 gfc_symtree
*symtree
;
12542 gfc_symtree
*this_symtree
;
12545 symbol_attribute class_attr
;
12546 gfc_array_spec
*as
;
12548 if (sym
->attr
.artificial
)
12551 if (sym
->attr
.flavor
== FL_UNKNOWN
12552 || (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.intrinsic
12553 && !sym
->attr
.generic
&& !sym
->attr
.external
12554 && sym
->attr
.if_source
== IFSRC_UNKNOWN
))
12557 /* If we find that a flavorless symbol is an interface in one of the
12558 parent namespaces, find its symtree in this namespace, free the
12559 symbol and set the symtree to point to the interface symbol. */
12560 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
12562 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
12563 if (symtree
&& (symtree
->n
.sym
->generic
||
12564 (symtree
->n
.sym
->attr
.flavor
== FL_PROCEDURE
12565 && sym
->ns
->construct_entities
)))
12567 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
12569 gfc_release_symbol (sym
);
12570 symtree
->n
.sym
->refs
++;
12571 this_symtree
->n
.sym
= symtree
->n
.sym
;
12576 /* Otherwise give it a flavor according to such attributes as
12578 if (sym
->attr
.flavor
== FL_UNKNOWN
&& sym
->attr
.external
== 0
12579 && sym
->attr
.intrinsic
== 0)
12580 sym
->attr
.flavor
= FL_VARIABLE
;
12581 else if (sym
->attr
.flavor
== FL_UNKNOWN
)
12583 sym
->attr
.flavor
= FL_PROCEDURE
;
12584 if (sym
->attr
.dimension
)
12585 sym
->attr
.function
= 1;
12589 if (sym
->attr
.external
&& sym
->ts
.type
!= BT_UNKNOWN
&& !sym
->attr
.function
)
12590 gfc_add_function (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12592 if (sym
->attr
.procedure
&& sym
->attr
.if_source
!= IFSRC_DECL
12593 && resolve_procedure_interface (sym
) == FAILURE
)
12596 if (sym
->attr
.is_protected
&& !sym
->attr
.proc_pointer
12597 && (sym
->attr
.procedure
|| sym
->attr
.external
))
12599 if (sym
->attr
.external
)
12600 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
12601 "at %L", &sym
->declared_at
);
12603 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
12604 "at %L", &sym
->declared_at
);
12609 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
12612 /* Symbols that are module procedures with results (functions) have
12613 the types and array specification copied for type checking in
12614 procedures that call them, as well as for saving to a module
12615 file. These symbols can't stand the scrutiny that their results
12617 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
12619 /* Make sure that the intrinsic is consistent with its internal
12620 representation. This needs to be done before assigning a default
12621 type to avoid spurious warnings. */
12622 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
12623 && gfc_resolve_intrinsic (sym
, &sym
->declared_at
) == FAILURE
)
12626 /* Resolve associate names. */
12628 resolve_assoc_var (sym
, true);
12630 /* Assign default type to symbols that need one and don't have one. */
12631 if (sym
->ts
.type
== BT_UNKNOWN
)
12633 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
12635 gfc_set_default_type (sym
, 1, NULL
);
12638 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.external
12639 && !sym
->attr
.function
&& !sym
->attr
.subroutine
12640 && gfc_get_default_type (sym
->name
, sym
->ns
)->type
== BT_UNKNOWN
)
12641 gfc_add_subroutine (&sym
->attr
, sym
->name
, &sym
->declared_at
);
12643 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12645 /* The specific case of an external procedure should emit an error
12646 in the case that there is no implicit type. */
12648 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
12651 /* Result may be in another namespace. */
12652 resolve_symbol (sym
->result
);
12654 if (!sym
->result
->attr
.proc_pointer
)
12656 sym
->ts
= sym
->result
->ts
;
12657 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
12658 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
12659 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
12660 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
12661 sym
->attr
.contiguous
= sym
->result
->attr
.contiguous
;
12666 else if (mp_flag
&& sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
12667 gfc_resolve_array_spec (sym
->result
->as
, false);
12669 if (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
)
12671 as
= CLASS_DATA (sym
)->as
;
12672 class_attr
= CLASS_DATA (sym
)->attr
;
12673 class_attr
.pointer
= class_attr
.class_pointer
;
12677 class_attr
= sym
->attr
;
12682 if (sym
->attr
.contiguous
12683 && (!class_attr
.dimension
12684 || (as
->type
!= AS_ASSUMED_SHAPE
&& as
->type
!= AS_ASSUMED_RANK
12685 && !class_attr
.pointer
)))
12687 gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
12688 "array pointer or an assumed-shape or assumed-rank array",
12689 sym
->name
, &sym
->declared_at
);
12693 /* Assumed size arrays and assumed shape arrays must be dummy
12694 arguments. Array-spec's of implied-shape should have been resolved to
12695 AS_EXPLICIT already. */
12699 gcc_assert (as
->type
!= AS_IMPLIED_SHAPE
);
12700 if (((as
->type
== AS_ASSUMED_SIZE
&& !as
->cp_was_assumed
)
12701 || as
->type
== AS_ASSUMED_SHAPE
)
12702 && sym
->attr
.dummy
== 0)
12704 if (as
->type
== AS_ASSUMED_SIZE
)
12705 gfc_error ("Assumed size array at %L must be a dummy argument",
12706 &sym
->declared_at
);
12708 gfc_error ("Assumed shape array at %L must be a dummy argument",
12709 &sym
->declared_at
);
12712 /* TS 29113, C535a. */
12713 if (as
->type
== AS_ASSUMED_RANK
&& !sym
->attr
.dummy
)
12715 gfc_error ("Assumed-rank array at %L must be a dummy argument",
12716 &sym
->declared_at
);
12719 if (as
->type
== AS_ASSUMED_RANK
12720 && (sym
->attr
.codimension
|| sym
->attr
.value
))
12722 gfc_error ("Assumed-rank array at %L may not have the VALUE or "
12723 "CODIMENSION attribute", &sym
->declared_at
);
12728 /* Make sure symbols with known intent or optional are really dummy
12729 variable. Because of ENTRY statement, this has to be deferred
12730 until resolution time. */
12732 if (!sym
->attr
.dummy
12733 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
12735 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
12739 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
12741 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
12742 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
12746 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
12748 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
12749 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
12751 gfc_error ("Character dummy variable '%s' at %L with VALUE "
12752 "attribute must have constant length",
12753 sym
->name
, &sym
->declared_at
);
12757 if (sym
->ts
.is_c_interop
12758 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
12760 gfc_error ("C interoperable character dummy variable '%s' at %L "
12761 "with VALUE attribute must have length one",
12762 sym
->name
, &sym
->declared_at
);
12767 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12768 && sym
->ts
.u
.derived
->attr
.generic
)
12770 sym
->ts
.u
.derived
= gfc_find_dt_in_generic (sym
->ts
.u
.derived
);
12771 if (!sym
->ts
.u
.derived
)
12773 gfc_error ("The derived type '%s' at %L is of type '%s', "
12774 "which has not been defined", sym
->name
,
12775 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12776 sym
->ts
.type
= BT_UNKNOWN
;
12781 if (sym
->ts
.type
== BT_ASSUMED
)
12783 /* TS 29113, C407a. */
12784 if (!sym
->attr
.dummy
)
12786 gfc_error ("Assumed type of variable %s at %L is only permitted "
12787 "for dummy variables", sym
->name
, &sym
->declared_at
);
12790 if (sym
->attr
.allocatable
|| sym
->attr
.codimension
12791 || sym
->attr
.pointer
|| sym
->attr
.value
)
12793 gfc_error ("Assumed-type variable %s at %L may not have the "
12794 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
12795 sym
->name
, &sym
->declared_at
);
12798 if (sym
->attr
.intent
== INTENT_OUT
)
12800 gfc_error ("Assumed-type variable %s at %L may not have the "
12801 "INTENT(OUT) attribute",
12802 sym
->name
, &sym
->declared_at
);
12805 if (sym
->attr
.dimension
&& sym
->as
->type
== AS_EXPLICIT
)
12807 gfc_error ("Assumed-type variable %s at %L shall not be an "
12808 "explicit-shape array", sym
->name
, &sym
->declared_at
);
12813 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
12814 do this for something that was implicitly typed because that is handled
12815 in gfc_set_default_type. Handle dummy arguments and procedure
12816 definitions separately. Also, anything that is use associated is not
12817 handled here but instead is handled in the module it is declared in.
12818 Finally, derived type definitions are allowed to be BIND(C) since that
12819 only implies that they're interoperable, and they are checked fully for
12820 interoperability when a variable is declared of that type. */
12821 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
12822 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
12823 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
12825 gfc_try t
= SUCCESS
;
12827 /* First, make sure the variable is declared at the
12828 module-level scope (J3/04-007, Section 15.3). */
12829 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
12830 sym
->attr
.in_common
== 0)
12832 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
12833 "is neither a COMMON block nor declared at the "
12834 "module level scope", sym
->name
, &(sym
->declared_at
));
12837 else if (sym
->common_head
!= NULL
)
12839 t
= verify_com_block_vars_c_interop (sym
->common_head
);
12843 /* If type() declaration, we need to verify that the components
12844 of the given type are all C interoperable, etc. */
12845 if (sym
->ts
.type
== BT_DERIVED
&&
12846 sym
->ts
.u
.derived
->attr
.is_c_interop
!= 1)
12848 /* Make sure the user marked the derived type as BIND(C). If
12849 not, call the verify routine. This could print an error
12850 for the derived type more than once if multiple variables
12851 of that type are declared. */
12852 if (sym
->ts
.u
.derived
->attr
.is_bind_c
!= 1)
12853 verify_bind_c_derived_type (sym
->ts
.u
.derived
);
12857 /* Verify the variable itself as C interoperable if it
12858 is BIND(C). It is not possible for this to succeed if
12859 the verify_bind_c_derived_type failed, so don't have to handle
12860 any error returned by verify_bind_c_derived_type. */
12861 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
12862 sym
->common_block
);
12867 /* clear the is_bind_c flag to prevent reporting errors more than
12868 once if something failed. */
12869 sym
->attr
.is_bind_c
= 0;
12874 /* If a derived type symbol has reached this point, without its
12875 type being declared, we have an error. Notice that most
12876 conditions that produce undefined derived types have already
12877 been dealt with. However, the likes of:
12878 implicit type(t) (t) ..... call foo (t) will get us here if
12879 the type is not declared in the scope of the implicit
12880 statement. Change the type to BT_UNKNOWN, both because it is so
12881 and to prevent an ICE. */
12882 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->attr
.is_iso_c
12883 && sym
->ts
.u
.derived
->components
== NULL
12884 && !sym
->ts
.u
.derived
->attr
.zero_comp
)
12886 gfc_error ("The derived type '%s' at %L is of type '%s', "
12887 "which has not been defined", sym
->name
,
12888 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
12889 sym
->ts
.type
= BT_UNKNOWN
;
12893 /* Make sure that the derived type has been resolved and that the
12894 derived type is visible in the symbol's namespace, if it is a
12895 module function and is not PRIVATE. */
12896 if (sym
->ts
.type
== BT_DERIVED
12897 && sym
->ts
.u
.derived
->attr
.use_assoc
12898 && sym
->ns
->proc_name
12899 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12900 && resolve_fl_derived (sym
->ts
.u
.derived
) == FAILURE
)
12903 /* Unless the derived-type declaration is use associated, Fortran 95
12904 does not allow public entries of private derived types.
12905 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
12906 161 in 95-006r3. */
12907 if (sym
->ts
.type
== BT_DERIVED
12908 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
12909 && !sym
->ts
.u
.derived
->attr
.use_assoc
12910 && gfc_check_symbol_access (sym
)
12911 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
12912 && gfc_notify_std (GFC_STD_F2003
, "PUBLIC %s '%s' at %L "
12913 "of PRIVATE derived type '%s'",
12914 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
12915 : "variable", sym
->name
, &sym
->declared_at
,
12916 sym
->ts
.u
.derived
->name
) == FAILURE
)
12919 /* F2008, C1302. */
12920 if (sym
->ts
.type
== BT_DERIVED
12921 && ((sym
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
12922 && sym
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
12923 || sym
->ts
.u
.derived
->attr
.lock_comp
)
12924 && !sym
->attr
.codimension
&& !sym
->ts
.u
.derived
->attr
.coarray_comp
)
12926 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of "
12927 "type LOCK_TYPE must be a coarray", sym
->name
,
12928 &sym
->declared_at
);
12932 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
12933 default initialization is defined (5.1.2.4.4). */
12934 if (sym
->ts
.type
== BT_DERIVED
12936 && sym
->attr
.intent
== INTENT_OUT
12938 && sym
->as
->type
== AS_ASSUMED_SIZE
)
12940 for (c
= sym
->ts
.u
.derived
->components
; c
; c
= c
->next
)
12942 if (c
->initializer
)
12944 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
12945 "ASSUMED SIZE and so cannot have a default initializer",
12946 sym
->name
, &sym
->declared_at
);
12953 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.dummy
12954 && sym
->attr
.intent
== INTENT_OUT
&& sym
->attr
.lock_comp
)
12956 gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be "
12957 "INTENT(OUT)", sym
->name
, &sym
->declared_at
);
12962 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12963 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12964 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12965 || class_attr
.codimension
)
12966 && (sym
->attr
.result
|| sym
->result
== sym
))
12968 gfc_error ("Function result '%s' at %L shall not be a coarray or have "
12969 "a coarray component", sym
->name
, &sym
->declared_at
);
12974 if (sym
->attr
.codimension
&& sym
->ts
.type
== BT_DERIVED
12975 && sym
->ts
.u
.derived
->ts
.is_iso_c
)
12977 gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
12978 "shall not be a coarray", sym
->name
, &sym
->declared_at
);
12983 if (((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
12984 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
12985 && CLASS_DATA (sym
)->attr
.coarray_comp
))
12986 && (class_attr
.codimension
|| class_attr
.pointer
|| class_attr
.dimension
12987 || class_attr
.allocatable
))
12989 gfc_error ("Variable '%s' at %L with coarray component "
12990 "shall be a nonpointer, nonallocatable scalar",
12991 sym
->name
, &sym
->declared_at
);
12995 /* F2008, C526. The function-result case was handled above. */
12996 if (class_attr
.codimension
12997 && !(class_attr
.allocatable
|| sym
->attr
.dummy
|| sym
->attr
.save
12998 || sym
->attr
.select_type_temporary
12999 || sym
->ns
->save_all
13000 || sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
13001 || sym
->ns
->proc_name
->attr
.is_main_program
13002 || sym
->attr
.function
|| sym
->attr
.result
|| sym
->attr
.use_assoc
))
13004 gfc_error ("Variable '%s' at %L is a coarray and is not ALLOCATABLE, SAVE "
13005 "nor a dummy argument", sym
->name
, &sym
->declared_at
);
13009 else if (class_attr
.codimension
&& !sym
->attr
.select_type_temporary
13010 && !class_attr
.allocatable
&& as
&& as
->cotype
== AS_DEFERRED
)
13012 gfc_error ("Coarray variable '%s' at %L shall not have codimensions with "
13013 "deferred shape", sym
->name
, &sym
->declared_at
);
13016 else if (class_attr
.codimension
&& class_attr
.allocatable
&& as
13017 && (as
->cotype
!= AS_DEFERRED
|| as
->type
!= AS_DEFERRED
))
13019 gfc_error ("Allocatable coarray variable '%s' at %L must have "
13020 "deferred shape", sym
->name
, &sym
->declared_at
);
13025 if ((((sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.u
.derived
->attr
.coarray_comp
)
13026 || (sym
->ts
.type
== BT_CLASS
&& sym
->attr
.class_ok
13027 && CLASS_DATA (sym
)->attr
.coarray_comp
))
13028 || (class_attr
.codimension
&& class_attr
.allocatable
))
13029 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
)
13031 gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an "
13032 "allocatable coarray or have coarray components",
13033 sym
->name
, &sym
->declared_at
);
13037 if (class_attr
.codimension
&& sym
->attr
.dummy
13038 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.is_bind_c
)
13040 gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) "
13041 "procedure '%s'", sym
->name
, &sym
->declared_at
,
13042 sym
->ns
->proc_name
->name
);
13046 switch (sym
->attr
.flavor
)
13049 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
13054 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
13059 if (resolve_fl_namelist (sym
) == FAILURE
)
13064 if (resolve_fl_parameter (sym
) == FAILURE
)
13072 /* Resolve array specifier. Check as well some constraints
13073 on COMMON blocks. */
13075 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
13077 /* Set the formal_arg_flag so that check_conflict will not throw
13078 an error for host associated variables in the specification
13079 expression for an array_valued function. */
13080 if (sym
->attr
.function
&& sym
->as
)
13081 formal_arg_flag
= 1;
13083 gfc_resolve_array_spec (sym
->as
, check_constant
);
13085 formal_arg_flag
= 0;
13087 /* Resolve formal namespaces. */
13088 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
13089 && !sym
->attr
.contained
&& !sym
->attr
.intrinsic
)
13090 gfc_resolve (sym
->formal_ns
);
13092 /* Make sure the formal namespace is present. */
13093 if (sym
->formal
&& !sym
->formal_ns
)
13095 gfc_formal_arglist
*formal
= sym
->formal
;
13096 while (formal
&& !formal
->sym
)
13097 formal
= formal
->next
;
13101 sym
->formal_ns
= formal
->sym
->ns
;
13102 if (sym
->ns
!= formal
->sym
->ns
)
13103 sym
->formal_ns
->refs
++;
13107 /* Check threadprivate restrictions. */
13108 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
13109 && (!sym
->attr
.in_common
13110 && sym
->module
== NULL
13111 && (sym
->ns
->proc_name
== NULL
13112 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
13113 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
13115 /* If we have come this far we can apply default-initializers, as
13116 described in 14.7.5, to those variables that have not already
13117 been assigned one. */
13118 if (sym
->ts
.type
== BT_DERIVED
13119 && sym
->ns
== gfc_current_ns
13121 && !sym
->attr
.allocatable
13122 && !sym
->attr
.alloc_comp
)
13124 symbol_attribute
*a
= &sym
->attr
;
13126 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
13127 && !a
->in_common
&& !a
->use_assoc
13128 && (a
->referenced
|| a
->result
)
13129 && !(a
->function
&& sym
!= sym
->result
))
13130 || (a
->dummy
&& a
->intent
== INTENT_OUT
&& !a
->pointer
))
13131 apply_default_init (sym
);
13134 if (sym
->ts
.type
== BT_CLASS
&& sym
->ns
== gfc_current_ns
13135 && sym
->attr
.dummy
&& sym
->attr
.intent
== INTENT_OUT
13136 && !CLASS_DATA (sym
)->attr
.class_pointer
13137 && !CLASS_DATA (sym
)->attr
.allocatable
)
13138 apply_default_init (sym
);
13140 /* If this symbol has a type-spec, check it. */
13141 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
13142 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
13143 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
13149 /************* Resolve DATA statements *************/
13153 gfc_data_value
*vnode
;
13159 /* Advance the values structure to point to the next value in the data list. */
13162 next_data_value (void)
13164 while (mpz_cmp_ui (values
.left
, 0) == 0)
13167 if (values
.vnode
->next
== NULL
)
13170 values
.vnode
= values
.vnode
->next
;
13171 mpz_set (values
.left
, values
.vnode
->repeat
);
13179 check_data_variable (gfc_data_variable
*var
, locus
*where
)
13185 ar_type mark
= AR_UNKNOWN
;
13187 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
13193 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
13197 mpz_init_set_si (offset
, 0);
13200 if (e
->expr_type
!= EXPR_VARIABLE
)
13201 gfc_internal_error ("check_data_variable(): Bad expression");
13203 sym
= e
->symtree
->n
.sym
;
13205 if (sym
->ns
->is_block_data
&& !sym
->attr
.in_common
)
13207 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
13208 sym
->name
, &sym
->declared_at
);
13211 if (e
->ref
== NULL
&& sym
->as
)
13213 gfc_error ("DATA array '%s' at %L must be specified in a previous"
13214 " declaration", sym
->name
, where
);
13218 has_pointer
= sym
->attr
.pointer
;
13220 if (gfc_is_coindexed (e
))
13222 gfc_error ("DATA element '%s' at %L cannot have a coindex", sym
->name
,
13227 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13229 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
13233 && ref
->type
== REF_ARRAY
13234 && ref
->u
.ar
.type
!= AR_FULL
)
13236 gfc_error ("DATA element '%s' at %L is a pointer and so must "
13237 "be a full array", sym
->name
, where
);
13242 if (e
->rank
== 0 || has_pointer
)
13244 mpz_init_set_ui (size
, 1);
13251 /* Find the array section reference. */
13252 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
13254 if (ref
->type
!= REF_ARRAY
)
13256 if (ref
->u
.ar
.type
== AR_ELEMENT
)
13262 /* Set marks according to the reference pattern. */
13263 switch (ref
->u
.ar
.type
)
13271 /* Get the start position of array section. */
13272 gfc_get_section_index (ar
, section_index
, &offset
);
13277 gcc_unreachable ();
13280 if (gfc_array_size (e
, &size
) == FAILURE
)
13282 gfc_error ("Nonconstant array section at %L in DATA statement",
13284 mpz_clear (offset
);
13291 while (mpz_cmp_ui (size
, 0) > 0)
13293 if (next_data_value () == FAILURE
)
13295 gfc_error ("DATA statement at %L has more variables than values",
13301 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
13305 /* If we have more than one element left in the repeat count,
13306 and we have more than one element left in the target variable,
13307 then create a range assignment. */
13308 /* FIXME: Only done for full arrays for now, since array sections
13310 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
13311 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
13315 if (mpz_cmp (size
, values
.left
) >= 0)
13317 mpz_init_set (range
, values
.left
);
13318 mpz_sub (size
, size
, values
.left
);
13319 mpz_set_ui (values
.left
, 0);
13323 mpz_init_set (range
, size
);
13324 mpz_sub (values
.left
, values
.left
, size
);
13325 mpz_set_ui (size
, 0);
13328 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13331 mpz_add (offset
, offset
, range
);
13338 /* Assign initial value to symbol. */
13341 mpz_sub_ui (values
.left
, values
.left
, 1);
13342 mpz_sub_ui (size
, size
, 1);
13344 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
,
13349 if (mark
== AR_FULL
)
13350 mpz_add_ui (offset
, offset
, 1);
13352 /* Modify the array section indexes and recalculate the offset
13353 for next element. */
13354 else if (mark
== AR_SECTION
)
13355 gfc_advance_section (section_index
, ar
, &offset
);
13359 if (mark
== AR_SECTION
)
13361 for (i
= 0; i
< ar
->dimen
; i
++)
13362 mpz_clear (section_index
[i
]);
13366 mpz_clear (offset
);
13372 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
13374 /* Iterate over a list of elements in a DATA statement. */
13377 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
13380 iterator_stack frame
;
13381 gfc_expr
*e
, *start
, *end
, *step
;
13382 gfc_try retval
= SUCCESS
;
13384 mpz_init (frame
.value
);
13387 start
= gfc_copy_expr (var
->iter
.start
);
13388 end
= gfc_copy_expr (var
->iter
.end
);
13389 step
= gfc_copy_expr (var
->iter
.step
);
13391 if (gfc_simplify_expr (start
, 1) == FAILURE
13392 || start
->expr_type
!= EXPR_CONSTANT
)
13394 gfc_error ("start of implied-do loop at %L could not be "
13395 "simplified to a constant value", &start
->where
);
13399 if (gfc_simplify_expr (end
, 1) == FAILURE
13400 || end
->expr_type
!= EXPR_CONSTANT
)
13402 gfc_error ("end of implied-do loop at %L could not be "
13403 "simplified to a constant value", &start
->where
);
13407 if (gfc_simplify_expr (step
, 1) == FAILURE
13408 || step
->expr_type
!= EXPR_CONSTANT
)
13410 gfc_error ("step of implied-do loop at %L could not be "
13411 "simplified to a constant value", &start
->where
);
13416 mpz_set (trip
, end
->value
.integer
);
13417 mpz_sub (trip
, trip
, start
->value
.integer
);
13418 mpz_add (trip
, trip
, step
->value
.integer
);
13420 mpz_div (trip
, trip
, step
->value
.integer
);
13422 mpz_set (frame
.value
, start
->value
.integer
);
13424 frame
.prev
= iter_stack
;
13425 frame
.variable
= var
->iter
.var
->symtree
;
13426 iter_stack
= &frame
;
13428 while (mpz_cmp_ui (trip
, 0) > 0)
13430 if (traverse_data_var (var
->list
, where
) == FAILURE
)
13436 e
= gfc_copy_expr (var
->expr
);
13437 if (gfc_simplify_expr (e
, 1) == FAILURE
)
13444 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
13446 mpz_sub_ui (trip
, trip
, 1);
13450 mpz_clear (frame
.value
);
13453 gfc_free_expr (start
);
13454 gfc_free_expr (end
);
13455 gfc_free_expr (step
);
13457 iter_stack
= frame
.prev
;
13462 /* Type resolve variables in the variable list of a DATA statement. */
13465 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
13469 for (; var
; var
= var
->next
)
13471 if (var
->expr
== NULL
)
13472 t
= traverse_data_list (var
, where
);
13474 t
= check_data_variable (var
, where
);
13484 /* Resolve the expressions and iterators associated with a data statement.
13485 This is separate from the assignment checking because data lists should
13486 only be resolved once. */
13489 resolve_data_variables (gfc_data_variable
*d
)
13491 for (; d
; d
= d
->next
)
13493 if (d
->list
== NULL
)
13495 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
13500 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
13503 if (resolve_data_variables (d
->list
) == FAILURE
)
13512 /* Resolve a single DATA statement. We implement this by storing a pointer to
13513 the value list into static variables, and then recursively traversing the
13514 variables list, expanding iterators and such. */
13517 resolve_data (gfc_data
*d
)
13520 if (resolve_data_variables (d
->var
) == FAILURE
)
13523 values
.vnode
= d
->value
;
13524 if (d
->value
== NULL
)
13525 mpz_set_ui (values
.left
, 0);
13527 mpz_set (values
.left
, d
->value
->repeat
);
13529 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
13532 /* At this point, we better not have any values left. */
13534 if (next_data_value () == SUCCESS
)
13535 gfc_error ("DATA statement at %L has more values than variables",
13540 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
13541 accessed by host or use association, is a dummy argument to a pure function,
13542 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
13543 is storage associated with any such variable, shall not be used in the
13544 following contexts: (clients of this function). */
13546 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
13547 procedure. Returns zero if assignment is OK, nonzero if there is a
13550 gfc_impure_variable (gfc_symbol
*sym
)
13555 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
13558 /* Check if the symbol's ns is inside the pure procedure. */
13559 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13563 if (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
13567 proc
= sym
->ns
->proc_name
;
13568 if (sym
->attr
.dummy
&& gfc_pure (proc
)
13569 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
13571 proc
->attr
.function
))
13574 /* TODO: Sort out what can be storage associated, if anything, and include
13575 it here. In principle equivalences should be scanned but it does not
13576 seem to be possible to storage associate an impure variable this way. */
13581 /* Test whether a symbol is pure or not. For a NULL pointer, checks if the
13582 current namespace is inside a pure procedure. */
13585 gfc_pure (gfc_symbol
*sym
)
13587 symbol_attribute attr
;
13592 /* Check if the current namespace or one of its parents
13593 belongs to a pure procedure. */
13594 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13596 sym
= ns
->proc_name
;
13600 if (attr
.flavor
== FL_PROCEDURE
&& attr
.pure
)
13608 return attr
.flavor
== FL_PROCEDURE
&& attr
.pure
;
13612 /* Test whether a symbol is implicitly pure or not. For a NULL pointer,
13613 checks if the current namespace is implicitly pure. Note that this
13614 function returns false for a PURE procedure. */
13617 gfc_implicit_pure (gfc_symbol
*sym
)
13623 /* Check if the current procedure is implicit_pure. Walk up
13624 the procedure list until we find a procedure. */
13625 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
13627 sym
= ns
->proc_name
;
13631 if (sym
->attr
.flavor
== FL_PROCEDURE
)
13636 return sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.implicit_pure
13637 && !sym
->attr
.pure
;
13641 /* Test whether the current procedure is elemental or not. */
13644 gfc_elemental (gfc_symbol
*sym
)
13646 symbol_attribute attr
;
13649 sym
= gfc_current_ns
->proc_name
;
13654 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
13658 /* Warn about unused labels. */
13661 warn_unused_fortran_label (gfc_st_label
*label
)
13666 warn_unused_fortran_label (label
->left
);
13668 if (label
->defined
== ST_LABEL_UNKNOWN
)
13671 switch (label
->referenced
)
13673 case ST_LABEL_UNKNOWN
:
13674 gfc_warning ("Label %d at %L defined but not used", label
->value
,
13678 case ST_LABEL_BAD_TARGET
:
13679 gfc_warning ("Label %d at %L defined but cannot be used",
13680 label
->value
, &label
->where
);
13687 warn_unused_fortran_label (label
->right
);
13691 /* Returns the sequence type of a symbol or sequence. */
13694 sequence_type (gfc_typespec ts
)
13703 if (ts
.u
.derived
->components
== NULL
)
13704 return SEQ_NONDEFAULT
;
13706 result
= sequence_type (ts
.u
.derived
->components
->ts
);
13707 for (c
= ts
.u
.derived
->components
->next
; c
; c
= c
->next
)
13708 if (sequence_type (c
->ts
) != result
)
13714 if (ts
.kind
!= gfc_default_character_kind
)
13715 return SEQ_NONDEFAULT
;
13717 return SEQ_CHARACTER
;
13720 if (ts
.kind
!= gfc_default_integer_kind
)
13721 return SEQ_NONDEFAULT
;
13723 return SEQ_NUMERIC
;
13726 if (!(ts
.kind
== gfc_default_real_kind
13727 || ts
.kind
== gfc_default_double_kind
))
13728 return SEQ_NONDEFAULT
;
13730 return SEQ_NUMERIC
;
13733 if (ts
.kind
!= gfc_default_complex_kind
)
13734 return SEQ_NONDEFAULT
;
13736 return SEQ_NUMERIC
;
13739 if (ts
.kind
!= gfc_default_logical_kind
)
13740 return SEQ_NONDEFAULT
;
13742 return SEQ_NUMERIC
;
13745 return SEQ_NONDEFAULT
;
13750 /* Resolve derived type EQUIVALENCE object. */
13753 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
13755 gfc_component
*c
= derived
->components
;
13760 /* Shall not be an object of nonsequence derived type. */
13761 if (!derived
->attr
.sequence
)
13763 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
13764 "attribute to be an EQUIVALENCE object", sym
->name
,
13769 /* Shall not have allocatable components. */
13770 if (derived
->attr
.alloc_comp
)
13772 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
13773 "components to be an EQUIVALENCE object",sym
->name
,
13778 if (sym
->attr
.in_common
&& gfc_has_default_initializer (sym
->ts
.u
.derived
))
13780 gfc_error ("Derived type variable '%s' at %L with default "
13781 "initialization cannot be in EQUIVALENCE with a variable "
13782 "in COMMON", sym
->name
, &e
->where
);
13786 for (; c
; c
= c
->next
)
13788 if (c
->ts
.type
== BT_DERIVED
13789 && (resolve_equivalence_derived (c
->ts
.u
.derived
, sym
, e
) == FAILURE
))
13792 /* Shall not be an object of sequence derived type containing a pointer
13793 in the structure. */
13794 if (c
->attr
.pointer
)
13796 gfc_error ("Derived type variable '%s' at %L with pointer "
13797 "component(s) cannot be an EQUIVALENCE object",
13798 sym
->name
, &e
->where
);
13806 /* Resolve equivalence object.
13807 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
13808 an allocatable array, an object of nonsequence derived type, an object of
13809 sequence derived type containing a pointer at any level of component
13810 selection, an automatic object, a function name, an entry name, a result
13811 name, a named constant, a structure component, or a subobject of any of
13812 the preceding objects. A substring shall not have length zero. A
13813 derived type shall not have components with default initialization nor
13814 shall two objects of an equivalence group be initialized.
13815 Either all or none of the objects shall have an protected attribute.
13816 The simple constraints are done in symbol.c(check_conflict) and the rest
13817 are implemented here. */
13820 resolve_equivalence (gfc_equiv
*eq
)
13823 gfc_symbol
*first_sym
;
13826 locus
*last_where
= NULL
;
13827 seq_type eq_type
, last_eq_type
;
13828 gfc_typespec
*last_ts
;
13829 int object
, cnt_protected
;
13832 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
13834 first_sym
= eq
->expr
->symtree
->n
.sym
;
13838 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
13842 e
->ts
= e
->symtree
->n
.sym
->ts
;
13843 /* match_varspec might not know yet if it is seeing
13844 array reference or substring reference, as it doesn't
13846 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
13848 gfc_ref
*ref
= e
->ref
;
13849 sym
= e
->symtree
->n
.sym
;
13851 if (sym
->attr
.dimension
)
13853 ref
->u
.ar
.as
= sym
->as
;
13857 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
13858 if (e
->ts
.type
== BT_CHARACTER
13860 && ref
->type
== REF_ARRAY
13861 && ref
->u
.ar
.dimen
== 1
13862 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
13863 && ref
->u
.ar
.stride
[0] == NULL
)
13865 gfc_expr
*start
= ref
->u
.ar
.start
[0];
13866 gfc_expr
*end
= ref
->u
.ar
.end
[0];
13869 /* Optimize away the (:) reference. */
13870 if (start
== NULL
&& end
== NULL
)
13873 e
->ref
= ref
->next
;
13875 e
->ref
->next
= ref
->next
;
13880 ref
->type
= REF_SUBSTRING
;
13882 start
= gfc_get_int_expr (gfc_default_integer_kind
,
13884 ref
->u
.ss
.start
= start
;
13885 if (end
== NULL
&& e
->ts
.u
.cl
)
13886 end
= gfc_copy_expr (e
->ts
.u
.cl
->length
);
13887 ref
->u
.ss
.end
= end
;
13888 ref
->u
.ss
.length
= e
->ts
.u
.cl
;
13895 /* Any further ref is an error. */
13898 gcc_assert (ref
->type
== REF_ARRAY
);
13899 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
13905 if (gfc_resolve_expr (e
) == FAILURE
)
13908 sym
= e
->symtree
->n
.sym
;
13910 if (sym
->attr
.is_protected
)
13912 if (cnt_protected
> 0 && cnt_protected
!= object
)
13914 gfc_error ("Either all or none of the objects in the "
13915 "EQUIVALENCE set at %L shall have the "
13916 "PROTECTED attribute",
13921 /* Shall not equivalence common block variables in a PURE procedure. */
13922 if (sym
->ns
->proc_name
13923 && sym
->ns
->proc_name
->attr
.pure
13924 && sym
->attr
.in_common
)
13926 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
13927 "object in the pure procedure '%s'",
13928 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
13932 /* Shall not be a named constant. */
13933 if (e
->expr_type
== EXPR_CONSTANT
)
13935 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
13936 "object", sym
->name
, &e
->where
);
13940 if (e
->ts
.type
== BT_DERIVED
13941 && resolve_equivalence_derived (e
->ts
.u
.derived
, sym
, e
) == FAILURE
)
13944 /* Check that the types correspond correctly:
13946 A numeric sequence structure may be equivalenced to another sequence
13947 structure, an object of default integer type, default real type, double
13948 precision real type, default logical type such that components of the
13949 structure ultimately only become associated to objects of the same
13950 kind. A character sequence structure may be equivalenced to an object
13951 of default character kind or another character sequence structure.
13952 Other objects may be equivalenced only to objects of the same type and
13953 kind parameters. */
13955 /* Identical types are unconditionally OK. */
13956 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
13957 goto identical_types
;
13959 last_eq_type
= sequence_type (*last_ts
);
13960 eq_type
= sequence_type (sym
->ts
);
13962 /* Since the pair of objects is not of the same type, mixed or
13963 non-default sequences can be rejected. */
13965 msg
= "Sequence %s with mixed components in EQUIVALENCE "
13966 "statement at %L with different type objects";
13968 && last_eq_type
== SEQ_MIXED
13969 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
13971 || (eq_type
== SEQ_MIXED
13972 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13973 &e
->where
) == FAILURE
))
13976 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
13977 "statement at %L with objects of different type";
13979 && last_eq_type
== SEQ_NONDEFAULT
13980 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
13981 last_where
) == FAILURE
)
13982 || (eq_type
== SEQ_NONDEFAULT
13983 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13984 &e
->where
) == FAILURE
))
13987 msg
="Non-CHARACTER object '%s' in default CHARACTER "
13988 "EQUIVALENCE statement at %L";
13989 if (last_eq_type
== SEQ_CHARACTER
13990 && eq_type
!= SEQ_CHARACTER
13991 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
13992 &e
->where
) == FAILURE
)
13995 msg
="Non-NUMERIC object '%s' in default NUMERIC "
13996 "EQUIVALENCE statement at %L";
13997 if (last_eq_type
== SEQ_NUMERIC
13998 && eq_type
!= SEQ_NUMERIC
13999 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
14000 &e
->where
) == FAILURE
)
14005 last_where
= &e
->where
;
14010 /* Shall not be an automatic array. */
14011 if (e
->ref
->type
== REF_ARRAY
14012 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
14014 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
14015 "an EQUIVALENCE object", sym
->name
, &e
->where
);
14022 /* Shall not be a structure component. */
14023 if (r
->type
== REF_COMPONENT
)
14025 gfc_error ("Structure component '%s' at %L cannot be an "
14026 "EQUIVALENCE object",
14027 r
->u
.c
.component
->name
, &e
->where
);
14031 /* A substring shall not have length zero. */
14032 if (r
->type
== REF_SUBSTRING
)
14034 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
14036 gfc_error ("Substring at %L has length zero",
14037 &r
->u
.ss
.start
->where
);
14047 /* Resolve function and ENTRY types, issue diagnostics if needed. */
14050 resolve_fntype (gfc_namespace
*ns
)
14052 gfc_entry_list
*el
;
14055 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
14058 /* If there are any entries, ns->proc_name is the entry master
14059 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
14061 sym
= ns
->entries
->sym
;
14063 sym
= ns
->proc_name
;
14064 if (sym
->result
== sym
14065 && sym
->ts
.type
== BT_UNKNOWN
14066 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
14067 && !sym
->attr
.untyped
)
14069 gfc_error ("Function '%s' at %L has no IMPLICIT type",
14070 sym
->name
, &sym
->declared_at
);
14071 sym
->attr
.untyped
= 1;
14074 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.u
.derived
->attr
.use_assoc
14075 && !sym
->attr
.contained
14076 && !gfc_check_symbol_access (sym
->ts
.u
.derived
)
14077 && gfc_check_symbol_access (sym
))
14079 gfc_notify_std (GFC_STD_F2003
, "PUBLIC function '%s' at "
14080 "%L of PRIVATE type '%s'", sym
->name
,
14081 &sym
->declared_at
, sym
->ts
.u
.derived
->name
);
14085 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
14087 if (el
->sym
->result
== el
->sym
14088 && el
->sym
->ts
.type
== BT_UNKNOWN
14089 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
14090 && !el
->sym
->attr
.untyped
)
14092 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
14093 el
->sym
->name
, &el
->sym
->declared_at
);
14094 el
->sym
->attr
.untyped
= 1;
14100 /* 12.3.2.1.1 Defined operators. */
14103 check_uop_procedure (gfc_symbol
*sym
, locus where
)
14105 gfc_formal_arglist
*formal
;
14107 if (!sym
->attr
.function
)
14109 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
14110 sym
->name
, &where
);
14114 if (sym
->ts
.type
== BT_CHARACTER
14115 && !(sym
->ts
.u
.cl
&& sym
->ts
.u
.cl
->length
)
14116 && !(sym
->result
&& sym
->result
->ts
.u
.cl
14117 && sym
->result
->ts
.u
.cl
->length
))
14119 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
14120 "character length", sym
->name
, &where
);
14124 formal
= sym
->formal
;
14125 if (!formal
|| !formal
->sym
)
14127 gfc_error ("User operator procedure '%s' at %L must have at least "
14128 "one argument", sym
->name
, &where
);
14132 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14134 gfc_error ("First argument of operator interface at %L must be "
14135 "INTENT(IN)", &where
);
14139 if (formal
->sym
->attr
.optional
)
14141 gfc_error ("First argument of operator interface at %L cannot be "
14142 "optional", &where
);
14146 formal
= formal
->next
;
14147 if (!formal
|| !formal
->sym
)
14150 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
14152 gfc_error ("Second argument of operator interface at %L must be "
14153 "INTENT(IN)", &where
);
14157 if (formal
->sym
->attr
.optional
)
14159 gfc_error ("Second argument of operator interface at %L cannot be "
14160 "optional", &where
);
14166 gfc_error ("Operator interface at %L must have, at most, two "
14167 "arguments", &where
);
14175 gfc_resolve_uops (gfc_symtree
*symtree
)
14177 gfc_interface
*itr
;
14179 if (symtree
== NULL
)
14182 gfc_resolve_uops (symtree
->left
);
14183 gfc_resolve_uops (symtree
->right
);
14185 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
14186 check_uop_procedure (itr
->sym
, itr
->sym
->declared_at
);
14190 /* Examine all of the expressions associated with a program unit,
14191 assign types to all intermediate expressions, make sure that all
14192 assignments are to compatible types and figure out which names
14193 refer to which functions or subroutines. It doesn't check code
14194 block, which is handled by resolve_code. */
14197 resolve_types (gfc_namespace
*ns
)
14203 gfc_namespace
* old_ns
= gfc_current_ns
;
14205 /* Check that all IMPLICIT types are ok. */
14206 if (!ns
->seen_implicit_none
)
14209 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
14210 if (ns
->set_flag
[letter
]
14211 && resolve_typespec_used (&ns
->default_type
[letter
],
14212 &ns
->implicit_loc
[letter
],
14217 gfc_current_ns
= ns
;
14219 resolve_entries (ns
);
14221 resolve_common_vars (ns
->blank_common
.head
, false);
14222 resolve_common_blocks (ns
->common_root
);
14224 resolve_contained_functions (ns
);
14226 if (ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
14227 && ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
14228 resolve_formal_arglist (ns
->proc_name
);
14230 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
14232 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
14233 resolve_charlen (cl
);
14235 gfc_traverse_ns (ns
, resolve_symbol
);
14237 resolve_fntype (ns
);
14239 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14241 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
14242 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
14243 "also be PURE", n
->proc_name
->name
,
14244 &n
->proc_name
->declared_at
);
14250 do_concurrent_flag
= 0;
14251 gfc_check_interfaces (ns
);
14253 gfc_traverse_ns (ns
, resolve_values
);
14259 for (d
= ns
->data
; d
; d
= d
->next
)
14263 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
14265 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
14267 if (ns
->common_root
!= NULL
)
14268 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
14270 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
14271 resolve_equivalence (eq
);
14273 /* Warn about unused labels. */
14274 if (warn_unused_label
)
14275 warn_unused_fortran_label (ns
->st_labels
);
14277 gfc_resolve_uops (ns
->uop_root
);
14279 gfc_current_ns
= old_ns
;
14283 /* Call resolve_code recursively. */
14286 resolve_codes (gfc_namespace
*ns
)
14289 bitmap_obstack old_obstack
;
14291 if (ns
->resolved
== 1)
14294 for (n
= ns
->contained
; n
; n
= n
->sibling
)
14297 gfc_current_ns
= ns
;
14299 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */
14300 if (!(ns
->proc_name
&& ns
->proc_name
->attr
.flavor
== FL_LABEL
))
14303 /* Set to an out of range value. */
14304 current_entry_id
= -1;
14306 old_obstack
= labels_obstack
;
14307 bitmap_obstack_initialize (&labels_obstack
);
14309 resolve_code (ns
->code
, ns
);
14311 bitmap_obstack_release (&labels_obstack
);
14312 labels_obstack
= old_obstack
;
14316 /* This function is called after a complete program unit has been compiled.
14317 Its purpose is to examine all of the expressions associated with a program
14318 unit, assign types to all intermediate expressions, make sure that all
14319 assignments are to compatible types and figure out which names refer to
14320 which functions or subroutines. */
14323 gfc_resolve (gfc_namespace
*ns
)
14325 gfc_namespace
*old_ns
;
14326 code_stack
*old_cs_base
;
14332 old_ns
= gfc_current_ns
;
14333 old_cs_base
= cs_base
;
14335 resolve_types (ns
);
14336 resolve_codes (ns
);
14338 gfc_current_ns
= old_ns
;
14339 cs_base
= old_cs_base
;
14342 gfc_run_passes (ns
);