1 /* Perform type resolution on the various structures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 #include "target-memory.h" /* for gfc_simplify_transfer */
33 /* Types used in equivalence statements. */
37 SEQ_NONDEFAULT
, SEQ_NUMERIC
, SEQ_CHARACTER
, SEQ_MIXED
41 /* Stack to keep track of the nesting of blocks as we move through the
42 code. See resolve_branch() and resolve_code(). */
44 typedef struct code_stack
46 struct gfc_code
*head
, *current
, *tail
;
47 struct code_stack
*prev
;
49 /* This bitmap keeps track of the targets valid for a branch from
51 bitmap reachable_labels
;
55 static code_stack
*cs_base
= NULL
;
58 /* Nonzero if we're inside a FORALL block. */
60 static int forall_flag
;
62 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
64 static int omp_workshare_flag
;
66 /* Nonzero if we are processing a formal arglist. The corresponding function
67 resets the flag each time that it is read. */
68 static int formal_arg_flag
= 0;
70 /* True if we are resolving a specification expression. */
71 static int specification_expr
= 0;
73 /* The id of the last entry seen. */
74 static int current_entry_id
;
76 /* We use bitmaps to determine if a branch target is valid. */
77 static bitmap_obstack labels_obstack
;
80 gfc_is_formal_arg (void)
82 return formal_arg_flag
;
86 /* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
87 an ABSTRACT derived-type. If where is not NULL, an error message with that
88 locus is printed, optionally using name. */
91 resolve_typespec_used (gfc_typespec
* ts
, locus
* where
, const char* name
)
93 if (ts
->type
== BT_DERIVED
&& ts
->derived
->attr
.abstract
)
98 gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
99 name
, where
, ts
->derived
->name
);
101 gfc_error ("ABSTRACT type '%s' used at %L",
102 ts
->derived
->name
, where
);
112 /* Resolve types of formal argument lists. These have to be done early so that
113 the formal argument lists of module procedures can be copied to the
114 containing module before the individual procedures are resolved
115 individually. We also resolve argument lists of procedures in interface
116 blocks because they are self-contained scoping units.
118 Since a dummy argument cannot be a non-dummy procedure, the only
119 resort left for untyped names are the IMPLICIT types. */
122 resolve_formal_arglist (gfc_symbol
*proc
)
124 gfc_formal_arglist
*f
;
128 if (proc
->result
!= NULL
)
133 if (gfc_elemental (proc
)
134 || sym
->attr
.pointer
|| sym
->attr
.allocatable
135 || (sym
->as
&& sym
->as
->rank
> 0))
137 proc
->attr
.always_explicit
= 1;
138 sym
->attr
.always_explicit
= 1;
143 for (f
= proc
->formal
; f
; f
= f
->next
)
149 /* Alternate return placeholder. */
150 if (gfc_elemental (proc
))
151 gfc_error ("Alternate return specifier in elemental subroutine "
152 "'%s' at %L is not allowed", proc
->name
,
154 if (proc
->attr
.function
)
155 gfc_error ("Alternate return specifier in function "
156 "'%s' at %L is not allowed", proc
->name
,
161 if (sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
162 resolve_formal_arglist (sym
);
164 if (sym
->attr
.subroutine
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
166 if (gfc_pure (proc
) && !gfc_pure (sym
))
168 gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
169 "also be PURE", sym
->name
, &sym
->declared_at
);
173 if (gfc_elemental (proc
))
175 gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
176 "procedure", &sym
->declared_at
);
180 if (sym
->attr
.function
181 && sym
->ts
.type
== BT_UNKNOWN
182 && sym
->attr
.intrinsic
)
184 gfc_intrinsic_sym
*isym
;
185 isym
= gfc_find_function (sym
->name
);
186 if (isym
== NULL
|| !isym
->specific
)
188 gfc_error ("Unable to find a specific INTRINSIC procedure "
189 "for the reference '%s' at %L", sym
->name
,
198 if (sym
->ts
.type
== BT_UNKNOWN
)
200 if (!sym
->attr
.function
|| sym
->result
== sym
)
201 gfc_set_default_type (sym
, 1, sym
->ns
);
204 gfc_resolve_array_spec (sym
->as
, 0);
206 /* We can't tell if an array with dimension (:) is assumed or deferred
207 shape until we know if it has the pointer or allocatable attributes.
209 if (sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_DEFERRED
210 && !(sym
->attr
.pointer
|| sym
->attr
.allocatable
))
212 sym
->as
->type
= AS_ASSUMED_SHAPE
;
213 for (i
= 0; i
< sym
->as
->rank
; i
++)
214 sym
->as
->lower
[i
] = gfc_int_expr (1);
217 if ((sym
->as
&& sym
->as
->rank
> 0 && sym
->as
->type
== AS_ASSUMED_SHAPE
)
218 || sym
->attr
.pointer
|| sym
->attr
.allocatable
|| sym
->attr
.target
219 || sym
->attr
.optional
)
221 proc
->attr
.always_explicit
= 1;
223 proc
->result
->attr
.always_explicit
= 1;
226 /* If the flavor is unknown at this point, it has to be a variable.
227 A procedure specification would have already set the type. */
229 if (sym
->attr
.flavor
== FL_UNKNOWN
)
230 gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, sym
->name
, &sym
->declared_at
);
232 if (gfc_pure (proc
) && !sym
->attr
.pointer
233 && sym
->attr
.flavor
!= FL_PROCEDURE
)
235 if (proc
->attr
.function
&& sym
->attr
.intent
!= INTENT_IN
)
236 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
237 "INTENT(IN)", sym
->name
, proc
->name
,
240 if (proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_UNKNOWN
)
241 gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
242 "have its INTENT specified", sym
->name
, proc
->name
,
246 if (gfc_elemental (proc
))
250 gfc_error ("Argument '%s' of elemental procedure at %L must "
251 "be scalar", sym
->name
, &sym
->declared_at
);
255 if (sym
->attr
.pointer
)
257 gfc_error ("Argument '%s' of elemental procedure at %L cannot "
258 "have the POINTER attribute", sym
->name
,
263 if (sym
->attr
.flavor
== FL_PROCEDURE
)
265 gfc_error ("Dummy procedure '%s' not allowed in elemental "
266 "procedure '%s' at %L", sym
->name
, proc
->name
,
272 /* Each dummy shall be specified to be scalar. */
273 if (proc
->attr
.proc
== PROC_ST_FUNCTION
)
277 gfc_error ("Argument '%s' of statement function at %L must "
278 "be scalar", sym
->name
, &sym
->declared_at
);
282 if (sym
->ts
.type
== BT_CHARACTER
)
284 gfc_charlen
*cl
= sym
->ts
.cl
;
285 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
287 gfc_error ("Character-valued argument '%s' of statement "
288 "function at %L must have constant length",
289 sym
->name
, &sym
->declared_at
);
299 /* Work function called when searching for symbols that have argument lists
300 associated with them. */
303 find_arglists (gfc_symbol
*sym
)
305 if (sym
->attr
.if_source
== IFSRC_UNKNOWN
|| sym
->ns
!= gfc_current_ns
)
308 resolve_formal_arglist (sym
);
312 /* Given a namespace, resolve all formal argument lists within the namespace.
316 resolve_formal_arglists (gfc_namespace
*ns
)
321 gfc_traverse_ns (ns
, find_arglists
);
326 resolve_contained_fntype (gfc_symbol
*sym
, gfc_namespace
*ns
)
330 /* If this namespace is not a function or an entry master function,
332 if (! sym
|| !(sym
->attr
.function
|| sym
->attr
.flavor
== FL_VARIABLE
)
333 || sym
->attr
.entry_master
)
336 /* Try to find out of what the return type is. */
337 if (sym
->result
->ts
.type
== BT_UNKNOWN
)
339 t
= gfc_set_default_type (sym
->result
, 0, ns
);
341 if (t
== FAILURE
&& !sym
->result
->attr
.untyped
)
343 if (sym
->result
== sym
)
344 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
345 sym
->name
, &sym
->declared_at
);
347 gfc_error ("Result '%s' of contained function '%s' at %L has "
348 "no IMPLICIT type", sym
->result
->name
, sym
->name
,
349 &sym
->result
->declared_at
);
350 sym
->result
->attr
.untyped
= 1;
354 /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
355 type, lists the only ways a character length value of * can be used:
356 dummy arguments of procedures, named constants, and function results
357 in external functions. Internal function results are not on that list;
358 ergo, not permitted. */
360 if (sym
->result
->ts
.type
== BT_CHARACTER
)
362 gfc_charlen
*cl
= sym
->result
->ts
.cl
;
363 if (!cl
|| !cl
->length
)
364 gfc_error ("Character-valued internal function '%s' at %L must "
365 "not be assumed length", sym
->name
, &sym
->declared_at
);
370 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
371 introduce duplicates. */
374 merge_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
376 gfc_formal_arglist
*f
, *new_arglist
;
379 for (; new_args
!= NULL
; new_args
= new_args
->next
)
381 new_sym
= new_args
->sym
;
382 /* See if this arg is already in the formal argument list. */
383 for (f
= proc
->formal
; f
; f
= f
->next
)
385 if (new_sym
== f
->sym
)
392 /* Add a new argument. Argument order is not important. */
393 new_arglist
= gfc_get_formal_arglist ();
394 new_arglist
->sym
= new_sym
;
395 new_arglist
->next
= proc
->formal
;
396 proc
->formal
= new_arglist
;
401 /* Flag the arguments that are not present in all entries. */
404 check_argument_lists (gfc_symbol
*proc
, gfc_formal_arglist
*new_args
)
406 gfc_formal_arglist
*f
, *head
;
409 for (f
= proc
->formal
; f
; f
= f
->next
)
414 for (new_args
= head
; new_args
; new_args
= new_args
->next
)
416 if (new_args
->sym
== f
->sym
)
423 f
->sym
->attr
.not_always_present
= 1;
428 /* Resolve alternate entry points. If a symbol has multiple entry points we
429 create a new master symbol for the main routine, and turn the existing
430 symbol into an entry point. */
433 resolve_entries (gfc_namespace
*ns
)
435 gfc_namespace
*old_ns
;
439 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
440 static int master_count
= 0;
442 if (ns
->proc_name
== NULL
)
445 /* No need to do anything if this procedure doesn't have alternate entry
450 /* We may already have resolved alternate entry points. */
451 if (ns
->proc_name
->attr
.entry_master
)
454 /* If this isn't a procedure something has gone horribly wrong. */
455 gcc_assert (ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
);
457 /* Remember the current namespace. */
458 old_ns
= gfc_current_ns
;
462 /* Add the main entry point to the list of entry points. */
463 el
= gfc_get_entry_list ();
464 el
->sym
= ns
->proc_name
;
466 el
->next
= ns
->entries
;
468 ns
->proc_name
->attr
.entry
= 1;
470 /* If it is a module function, it needs to be in the right namespace
471 so that gfc_get_fake_result_decl can gather up the results. The
472 need for this arose in get_proc_name, where these beasts were
473 left in their own namespace, to keep prior references linked to
474 the entry declaration.*/
475 if (ns
->proc_name
->attr
.function
476 && ns
->parent
&& ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
479 /* Do the same for entries where the master is not a module
480 procedure. These are retained in the module namespace because
481 of the module procedure declaration. */
482 for (el
= el
->next
; el
; el
= el
->next
)
483 if (el
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
484 && el
->sym
->attr
.mod_proc
)
488 /* Add an entry statement for it. */
495 /* Create a new symbol for the master function. */
496 /* Give the internal function a unique name (within this file).
497 Also include the function name so the user has some hope of figuring
498 out what is going on. */
499 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "master.%d.%s",
500 master_count
++, ns
->proc_name
->name
);
501 gfc_get_ha_symbol (name
, &proc
);
502 gcc_assert (proc
!= NULL
);
504 gfc_add_procedure (&proc
->attr
, PROC_INTERNAL
, proc
->name
, NULL
);
505 if (ns
->proc_name
->attr
.subroutine
)
506 gfc_add_subroutine (&proc
->attr
, proc
->name
, NULL
);
510 gfc_typespec
*ts
, *fts
;
511 gfc_array_spec
*as
, *fas
;
512 gfc_add_function (&proc
->attr
, proc
->name
, NULL
);
514 fas
= ns
->entries
->sym
->as
;
515 fas
= fas
? fas
: ns
->entries
->sym
->result
->as
;
516 fts
= &ns
->entries
->sym
->result
->ts
;
517 if (fts
->type
== BT_UNKNOWN
)
518 fts
= gfc_get_default_type (ns
->entries
->sym
->result
, NULL
);
519 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
521 ts
= &el
->sym
->result
->ts
;
523 as
= as
? as
: el
->sym
->result
->as
;
524 if (ts
->type
== BT_UNKNOWN
)
525 ts
= gfc_get_default_type (el
->sym
->result
, NULL
);
527 if (! gfc_compare_types (ts
, fts
)
528 || (el
->sym
->result
->attr
.dimension
529 != ns
->entries
->sym
->result
->attr
.dimension
)
530 || (el
->sym
->result
->attr
.pointer
531 != ns
->entries
->sym
->result
->attr
.pointer
))
533 else if (as
&& fas
&& ns
->entries
->sym
->result
!= el
->sym
->result
534 && gfc_compare_array_spec (as
, fas
) == 0)
535 gfc_error ("Function %s at %L has entries with mismatched "
536 "array specifications", ns
->entries
->sym
->name
,
537 &ns
->entries
->sym
->declared_at
);
538 /* The characteristics need to match and thus both need to have
539 the same string length, i.e. both len=*, or both len=4.
540 Having both len=<variable> is also possible, but difficult to
541 check at compile time. */
542 else if (ts
->type
== BT_CHARACTER
&& ts
->cl
&& fts
->cl
543 && (((ts
->cl
->length
&& !fts
->cl
->length
)
544 ||(!ts
->cl
->length
&& fts
->cl
->length
))
546 && ts
->cl
->length
->expr_type
547 != fts
->cl
->length
->expr_type
)
549 && ts
->cl
->length
->expr_type
== EXPR_CONSTANT
550 && mpz_cmp (ts
->cl
->length
->value
.integer
,
551 fts
->cl
->length
->value
.integer
) != 0)))
552 gfc_notify_std (GFC_STD_GNU
, "Extension: Function %s at %L with "
553 "entries returning variables of different "
554 "string lengths", ns
->entries
->sym
->name
,
555 &ns
->entries
->sym
->declared_at
);
560 sym
= ns
->entries
->sym
->result
;
561 /* All result types the same. */
563 if (sym
->attr
.dimension
)
564 gfc_set_array_spec (proc
, gfc_copy_array_spec (sym
->as
), NULL
);
565 if (sym
->attr
.pointer
)
566 gfc_add_pointer (&proc
->attr
, NULL
);
570 /* Otherwise the result will be passed through a union by
572 proc
->attr
.mixed_entry_master
= 1;
573 for (el
= ns
->entries
; el
; el
= el
->next
)
575 sym
= el
->sym
->result
;
576 if (sym
->attr
.dimension
)
578 if (el
== ns
->entries
)
579 gfc_error ("FUNCTION result %s can't be an array in "
580 "FUNCTION %s at %L", sym
->name
,
581 ns
->entries
->sym
->name
, &sym
->declared_at
);
583 gfc_error ("ENTRY result %s can't be an array in "
584 "FUNCTION %s at %L", sym
->name
,
585 ns
->entries
->sym
->name
, &sym
->declared_at
);
587 else if (sym
->attr
.pointer
)
589 if (el
== ns
->entries
)
590 gfc_error ("FUNCTION result %s can't be a POINTER in "
591 "FUNCTION %s at %L", sym
->name
,
592 ns
->entries
->sym
->name
, &sym
->declared_at
);
594 gfc_error ("ENTRY result %s can't be a POINTER in "
595 "FUNCTION %s at %L", sym
->name
,
596 ns
->entries
->sym
->name
, &sym
->declared_at
);
601 if (ts
->type
== BT_UNKNOWN
)
602 ts
= gfc_get_default_type (sym
, NULL
);
606 if (ts
->kind
== gfc_default_integer_kind
)
610 if (ts
->kind
== gfc_default_real_kind
611 || ts
->kind
== gfc_default_double_kind
)
615 if (ts
->kind
== gfc_default_complex_kind
)
619 if (ts
->kind
== gfc_default_logical_kind
)
623 /* We will issue error elsewhere. */
631 if (el
== ns
->entries
)
632 gfc_error ("FUNCTION result %s can't be of type %s "
633 "in FUNCTION %s at %L", sym
->name
,
634 gfc_typename (ts
), ns
->entries
->sym
->name
,
637 gfc_error ("ENTRY result %s can't be of type %s "
638 "in FUNCTION %s at %L", sym
->name
,
639 gfc_typename (ts
), ns
->entries
->sym
->name
,
646 proc
->attr
.access
= ACCESS_PRIVATE
;
647 proc
->attr
.entry_master
= 1;
649 /* Merge all the entry point arguments. */
650 for (el
= ns
->entries
; el
; el
= el
->next
)
651 merge_argument_lists (proc
, el
->sym
->formal
);
653 /* Check the master formal arguments for any that are not
654 present in all entry points. */
655 for (el
= ns
->entries
; el
; el
= el
->next
)
656 check_argument_lists (proc
, el
->sym
->formal
);
658 /* Use the master function for the function body. */
659 ns
->proc_name
= proc
;
661 /* Finalize the new symbols. */
662 gfc_commit_symbols ();
664 /* Restore the original namespace. */
665 gfc_current_ns
= old_ns
;
670 has_default_initializer (gfc_symbol
*der
)
674 gcc_assert (der
->attr
.flavor
== FL_DERIVED
);
675 for (c
= der
->components
; c
; c
= c
->next
)
676 if ((c
->ts
.type
!= BT_DERIVED
&& c
->initializer
)
677 || (c
->ts
.type
== BT_DERIVED
678 && (!c
->attr
.pointer
&& has_default_initializer (c
->ts
.derived
))))
684 /* Resolve common variables. */
686 resolve_common_vars (gfc_symbol
*sym
, bool named_common
)
688 gfc_symbol
*csym
= sym
;
690 for (; csym
; csym
= csym
->common_next
)
692 if (csym
->value
|| csym
->attr
.data
)
694 if (!csym
->ns
->is_block_data
)
695 gfc_notify_std (GFC_STD_GNU
, "Variable '%s' at %L is in COMMON "
696 "but only in BLOCK DATA initialization is "
697 "allowed", csym
->name
, &csym
->declared_at
);
698 else if (!named_common
)
699 gfc_notify_std (GFC_STD_GNU
, "Initialized variable '%s' at %L is "
700 "in a blank COMMON but initialization is only "
701 "allowed in named common blocks", csym
->name
,
705 if (csym
->ts
.type
!= BT_DERIVED
)
708 if (!(csym
->ts
.derived
->attr
.sequence
709 || csym
->ts
.derived
->attr
.is_bind_c
))
710 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
711 "has neither the SEQUENCE nor the BIND(C) "
712 "attribute", csym
->name
, &csym
->declared_at
);
713 if (csym
->ts
.derived
->attr
.alloc_comp
)
714 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
715 "has an ultimate component that is "
716 "allocatable", csym
->name
, &csym
->declared_at
);
717 if (has_default_initializer (csym
->ts
.derived
))
718 gfc_error_now ("Derived type variable '%s' in COMMON at %L "
719 "may not have default initializer", csym
->name
,
724 /* Resolve common blocks. */
726 resolve_common_blocks (gfc_symtree
*common_root
)
730 if (common_root
== NULL
)
733 if (common_root
->left
)
734 resolve_common_blocks (common_root
->left
);
735 if (common_root
->right
)
736 resolve_common_blocks (common_root
->right
);
738 resolve_common_vars (common_root
->n
.common
->head
, true);
740 gfc_find_symbol (common_root
->name
, gfc_current_ns
, 0, &sym
);
744 if (sym
->attr
.flavor
== FL_PARAMETER
)
745 gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
746 sym
->name
, &common_root
->n
.common
->where
, &sym
->declared_at
);
748 if (sym
->attr
.intrinsic
)
749 gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
750 sym
->name
, &common_root
->n
.common
->where
);
751 else if (sym
->attr
.result
752 ||(sym
->attr
.function
&& gfc_current_ns
->proc_name
== sym
))
753 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
754 "that is also a function result", sym
->name
,
755 &common_root
->n
.common
->where
);
756 else if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.proc
!= PROC_INTERNAL
757 && sym
->attr
.proc
!= PROC_ST_FUNCTION
)
758 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: COMMON block '%s' at %L "
759 "that is also a global procedure", sym
->name
,
760 &common_root
->n
.common
->where
);
764 /* Resolve contained function types. Because contained functions can call one
765 another, they have to be worked out before any of the contained procedures
768 The good news is that if a function doesn't already have a type, the only
769 way it can get one is through an IMPLICIT type or a RESULT variable, because
770 by definition contained functions are contained namespace they're contained
771 in, not in a sibling or parent namespace. */
774 resolve_contained_functions (gfc_namespace
*ns
)
776 gfc_namespace
*child
;
779 resolve_formal_arglists (ns
);
781 for (child
= ns
->contained
; child
; child
= child
->sibling
)
783 /* Resolve alternate entry points first. */
784 resolve_entries (child
);
786 /* Then check function return types. */
787 resolve_contained_fntype (child
->proc_name
, child
);
788 for (el
= child
->entries
; el
; el
= el
->next
)
789 resolve_contained_fntype (el
->sym
, child
);
794 /* Resolve all of the elements of a structure constructor and make sure that
795 the types are correct. */
798 resolve_structure_cons (gfc_expr
*expr
)
800 gfc_constructor
*cons
;
806 cons
= expr
->value
.constructor
;
807 /* A constructor may have references if it is the result of substituting a
808 parameter variable. In this case we just pull out the component we
811 comp
= expr
->ref
->u
.c
.sym
->components
;
813 comp
= expr
->ts
.derived
->components
;
815 /* See if the user is trying to invoke a structure constructor for one of
816 the iso_c_binding derived types. */
817 if (expr
->ts
.derived
&& expr
->ts
.derived
->ts
.is_iso_c
&& cons
818 && cons
->expr
!= NULL
)
820 gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
821 expr
->ts
.derived
->name
, &(expr
->where
));
825 for (; comp
; comp
= comp
->next
, cons
= cons
->next
)
832 if (gfc_resolve_expr (cons
->expr
) == FAILURE
)
838 rank
= comp
->as
? comp
->as
->rank
: 0;
839 if (cons
->expr
->expr_type
!= EXPR_NULL
&& rank
!= cons
->expr
->rank
840 && (comp
->attr
.allocatable
|| cons
->expr
->rank
))
842 gfc_error ("The rank of the element in the derived type "
843 "constructor at %L does not match that of the "
844 "component (%d/%d)", &cons
->expr
->where
,
845 cons
->expr
->rank
, rank
);
849 /* If we don't have the right type, try to convert it. */
851 if (!gfc_compare_types (&cons
->expr
->ts
, &comp
->ts
))
854 if (comp
->attr
.pointer
&& cons
->expr
->ts
.type
!= BT_UNKNOWN
)
855 gfc_error ("The element in the derived type constructor at %L, "
856 "for pointer component '%s', is %s but should be %s",
857 &cons
->expr
->where
, comp
->name
,
858 gfc_basic_typename (cons
->expr
->ts
.type
),
859 gfc_basic_typename (comp
->ts
.type
));
861 t
= gfc_convert_type (cons
->expr
, &comp
->ts
, 1);
864 if (cons
->expr
->expr_type
== EXPR_NULL
865 && !(comp
->attr
.pointer
|| comp
->attr
.allocatable
))
868 gfc_error ("The NULL in the derived type constructor at %L is "
869 "being applied to component '%s', which is neither "
870 "a POINTER nor ALLOCATABLE", &cons
->expr
->where
,
874 if (!comp
->attr
.pointer
|| cons
->expr
->expr_type
== EXPR_NULL
)
877 a
= gfc_expr_attr (cons
->expr
);
879 if (!a
.pointer
&& !a
.target
)
882 gfc_error ("The element in the derived type constructor at %L, "
883 "for pointer component '%s' should be a POINTER or "
884 "a TARGET", &cons
->expr
->where
, comp
->name
);
892 /****************** Expression name resolution ******************/
894 /* Returns 0 if a symbol was not declared with a type or
895 attribute declaration statement, nonzero otherwise. */
898 was_declared (gfc_symbol
*sym
)
904 if (!a
.implicit_type
&& sym
->ts
.type
!= BT_UNKNOWN
)
907 if (a
.allocatable
|| a
.dimension
|| a
.dummy
|| a
.external
|| a
.intrinsic
908 || a
.optional
|| a
.pointer
|| a
.save
|| a
.target
|| a
.volatile_
909 || a
.value
|| a
.access
!= ACCESS_UNKNOWN
|| a
.intent
!= INTENT_UNKNOWN
)
916 /* Determine if a symbol is generic or not. */
919 generic_sym (gfc_symbol
*sym
)
923 if (sym
->attr
.generic
||
924 (sym
->attr
.intrinsic
&& gfc_generic_intrinsic (sym
->name
)))
927 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
930 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
937 return generic_sym (s
);
944 /* Determine if a symbol is specific or not. */
947 specific_sym (gfc_symbol
*sym
)
951 if (sym
->attr
.if_source
== IFSRC_IFBODY
952 || sym
->attr
.proc
== PROC_MODULE
953 || sym
->attr
.proc
== PROC_INTERNAL
954 || sym
->attr
.proc
== PROC_ST_FUNCTION
955 || (sym
->attr
.intrinsic
&& gfc_specific_intrinsic (sym
->name
))
956 || sym
->attr
.external
)
959 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
962 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &s
);
964 return (s
== NULL
) ? 0 : specific_sym (s
);
968 /* Figure out if the procedure is specific, generic or unknown. */
971 { PTYPE_GENERIC
= 1, PTYPE_SPECIFIC
, PTYPE_UNKNOWN
}
975 procedure_kind (gfc_symbol
*sym
)
977 if (generic_sym (sym
))
978 return PTYPE_GENERIC
;
980 if (specific_sym (sym
))
981 return PTYPE_SPECIFIC
;
983 return PTYPE_UNKNOWN
;
986 /* Check references to assumed size arrays. The flag need_full_assumed_size
987 is nonzero when matching actual arguments. */
989 static int need_full_assumed_size
= 0;
992 check_assumed_size_reference (gfc_symbol
*sym
, gfc_expr
*e
)
994 if (need_full_assumed_size
|| !(sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
))
997 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
998 What should it be? */
999 if ((e
->ref
->u
.ar
.end
[e
->ref
->u
.ar
.as
->rank
- 1] == NULL
)
1000 && (e
->ref
->u
.ar
.as
->type
== AS_ASSUMED_SIZE
)
1001 && (e
->ref
->u
.ar
.type
== AR_FULL
))
1003 gfc_error ("The upper bound in the last dimension must "
1004 "appear in the reference to the assumed size "
1005 "array '%s' at %L", sym
->name
, &e
->where
);
1012 /* Look for bad assumed size array references in argument expressions
1013 of elemental and array valued intrinsic procedures. Since this is
1014 called from procedure resolution functions, it only recurses at
1018 resolve_assumed_size_actual (gfc_expr
*e
)
1023 switch (e
->expr_type
)
1026 if (e
->symtree
&& check_assumed_size_reference (e
->symtree
->n
.sym
, e
))
1031 if (resolve_assumed_size_actual (e
->value
.op
.op1
)
1032 || resolve_assumed_size_actual (e
->value
.op
.op2
))
1043 /* Check a generic procedure, passed as an actual argument, to see if
1044 there is a matching specific name. If none, it is an error, and if
1045 more than one, the reference is ambiguous. */
1047 count_specific_procs (gfc_expr
*e
)
1054 sym
= e
->symtree
->n
.sym
;
1056 for (p
= sym
->generic
; p
; p
= p
->next
)
1057 if (strcmp (sym
->name
, p
->sym
->name
) == 0)
1059 e
->symtree
= gfc_find_symtree (p
->sym
->ns
->sym_root
,
1065 gfc_error ("'%s' at %L is ambiguous", e
->symtree
->n
.sym
->name
,
1069 gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
1070 "argument at %L", sym
->name
, &e
->where
);
1076 /* See if a call to sym could possibly be a not allowed RECURSION because of
1077 a missing RECURIVE declaration. This means that either sym is the current
1078 context itself, or sym is the parent of a contained procedure calling its
1079 non-RECURSIVE containing procedure.
1080 This also works if sym is an ENTRY. */
1083 is_illegal_recursion (gfc_symbol
* sym
, gfc_namespace
* context
)
1085 gfc_symbol
* proc_sym
;
1086 gfc_symbol
* context_proc
;
1088 gcc_assert (sym
->attr
.flavor
== FL_PROCEDURE
);
1090 /* If we've got an ENTRY, find real procedure. */
1091 if (sym
->attr
.entry
&& sym
->ns
->entries
)
1092 proc_sym
= sym
->ns
->entries
->sym
;
1096 /* If sym is RECURSIVE, all is well of course. */
1097 if (proc_sym
->attr
.recursive
|| gfc_option
.flag_recursive
)
1100 /* Find the context procdure's "real" symbol if it has entries. */
1101 context_proc
= (context
->entries
? context
->entries
->sym
1102 : context
->proc_name
);
1106 /* A call from sym's body to itself is recursion, of course. */
1107 if (context_proc
== proc_sym
)
1110 /* The same is true if context is a contained procedure and sym the
1112 if (context_proc
->attr
.contained
)
1114 gfc_symbol
* parent_proc
;
1116 gcc_assert (context
->parent
);
1117 parent_proc
= (context
->parent
->entries
? context
->parent
->entries
->sym
1118 : context
->parent
->proc_name
);
1120 if (parent_proc
== proc_sym
)
1128 /* Resolve a procedure expression, like passing it to a called procedure or as
1129 RHS for a procedure pointer assignment. */
1132 resolve_procedure_expression (gfc_expr
* expr
)
1136 if (expr
->expr_type
!= EXPR_VARIABLE
)
1138 gcc_assert (expr
->symtree
);
1140 sym
= expr
->symtree
->n
.sym
;
1141 if (sym
->attr
.flavor
!= FL_PROCEDURE
1142 || (sym
->attr
.function
&& sym
->result
== sym
))
1145 /* A non-RECURSIVE procedure that is used as procedure expression within its
1146 own body is in danger of being called recursively. */
1147 if (is_illegal_recursion (sym
, gfc_current_ns
))
1148 gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
1149 " itself recursively. Declare it RECURSIVE or use"
1150 " -frecursive", sym
->name
, &expr
->where
);
1156 /* Resolve an actual argument list. Most of the time, this is just
1157 resolving the expressions in the list.
1158 The exception is that we sometimes have to decide whether arguments
1159 that look like procedure arguments are really simple variable
1163 resolve_actual_arglist (gfc_actual_arglist
*arg
, procedure_type ptype
,
1164 bool no_formal_args
)
1167 gfc_symtree
*parent_st
;
1169 int save_need_full_assumed_size
;
1171 for (; arg
; arg
= arg
->next
)
1176 /* Check the label is a valid branching target. */
1179 if (arg
->label
->defined
== ST_LABEL_UNKNOWN
)
1181 gfc_error ("Label %d referenced at %L is never defined",
1182 arg
->label
->value
, &arg
->label
->where
);
1189 if (e
->expr_type
== EXPR_VARIABLE
1190 && e
->symtree
->n
.sym
->attr
.generic
1192 && count_specific_procs (e
) != 1)
1195 if (e
->ts
.type
!= BT_PROCEDURE
)
1197 save_need_full_assumed_size
= need_full_assumed_size
;
1198 if (e
->expr_type
!= EXPR_VARIABLE
)
1199 need_full_assumed_size
= 0;
1200 if (gfc_resolve_expr (e
) != SUCCESS
)
1202 need_full_assumed_size
= save_need_full_assumed_size
;
1206 /* See if the expression node should really be a variable reference. */
1208 sym
= e
->symtree
->n
.sym
;
1210 if (sym
->attr
.flavor
== FL_PROCEDURE
1211 || sym
->attr
.intrinsic
1212 || sym
->attr
.external
)
1216 /* If a procedure is not already determined to be something else
1217 check if it is intrinsic. */
1218 if (!sym
->attr
.intrinsic
1219 && !(sym
->attr
.external
|| sym
->attr
.use_assoc
1220 || sym
->attr
.if_source
== IFSRC_IFBODY
)
1221 && gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, e
->where
))
1222 sym
->attr
.intrinsic
= 1;
1224 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1226 gfc_error ("Statement function '%s' at %L is not allowed as an "
1227 "actual argument", sym
->name
, &e
->where
);
1230 actual_ok
= gfc_intrinsic_actual_ok (sym
->name
,
1231 sym
->attr
.subroutine
);
1232 if (sym
->attr
.intrinsic
&& actual_ok
== 0)
1234 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
1235 "actual argument", sym
->name
, &e
->where
);
1238 if (sym
->attr
.contained
&& !sym
->attr
.use_assoc
1239 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
1241 gfc_error ("Internal procedure '%s' is not allowed as an "
1242 "actual argument at %L", sym
->name
, &e
->where
);
1245 if (sym
->attr
.elemental
&& !sym
->attr
.intrinsic
)
1247 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
1248 "allowed as an actual argument at %L", sym
->name
,
1252 /* Check if a generic interface has a specific procedure
1253 with the same name before emitting an error. */
1254 if (sym
->attr
.generic
&& count_specific_procs (e
) != 1)
1257 /* Just in case a specific was found for the expression. */
1258 sym
= e
->symtree
->n
.sym
;
1260 /* If the symbol is the function that names the current (or
1261 parent) scope, then we really have a variable reference. */
1263 if (sym
->attr
.function
&& sym
->result
== sym
1264 && (sym
->ns
->proc_name
== sym
1265 || (sym
->ns
->parent
!= NULL
1266 && sym
->ns
->parent
->proc_name
== sym
)))
1269 /* If all else fails, see if we have a specific intrinsic. */
1270 if (sym
->ts
.type
== BT_UNKNOWN
&& sym
->attr
.intrinsic
)
1272 gfc_intrinsic_sym
*isym
;
1274 isym
= gfc_find_function (sym
->name
);
1275 if (isym
== NULL
|| !isym
->specific
)
1277 gfc_error ("Unable to find a specific INTRINSIC procedure "
1278 "for the reference '%s' at %L", sym
->name
,
1283 sym
->attr
.intrinsic
= 1;
1284 sym
->attr
.function
= 1;
1287 if (gfc_resolve_expr (e
) == FAILURE
)
1292 /* See if the name is a module procedure in a parent unit. */
1294 if (was_declared (sym
) || sym
->ns
->parent
== NULL
)
1297 if (gfc_find_sym_tree (sym
->name
, sym
->ns
->parent
, 1, &parent_st
))
1299 gfc_error ("Symbol '%s' at %L is ambiguous", sym
->name
, &e
->where
);
1303 if (parent_st
== NULL
)
1306 sym
= parent_st
->n
.sym
;
1307 e
->symtree
= parent_st
; /* Point to the right thing. */
1309 if (sym
->attr
.flavor
== FL_PROCEDURE
1310 || sym
->attr
.intrinsic
1311 || sym
->attr
.external
)
1313 if (gfc_resolve_expr (e
) == FAILURE
)
1319 e
->expr_type
= EXPR_VARIABLE
;
1321 if (sym
->as
!= NULL
)
1323 e
->rank
= sym
->as
->rank
;
1324 e
->ref
= gfc_get_ref ();
1325 e
->ref
->type
= REF_ARRAY
;
1326 e
->ref
->u
.ar
.type
= AR_FULL
;
1327 e
->ref
->u
.ar
.as
= sym
->as
;
1330 /* Expressions are assigned a default ts.type of BT_PROCEDURE in
1331 primary.c (match_actual_arg). If above code determines that it
1332 is a variable instead, it needs to be resolved as it was not
1333 done at the beginning of this function. */
1334 save_need_full_assumed_size
= need_full_assumed_size
;
1335 if (e
->expr_type
!= EXPR_VARIABLE
)
1336 need_full_assumed_size
= 0;
1337 if (gfc_resolve_expr (e
) != SUCCESS
)
1339 need_full_assumed_size
= save_need_full_assumed_size
;
1342 /* Check argument list functions %VAL, %LOC and %REF. There is
1343 nothing to do for %REF. */
1344 if (arg
->name
&& arg
->name
[0] == '%')
1346 if (strncmp ("%VAL", arg
->name
, 4) == 0)
1348 if (e
->ts
.type
== BT_CHARACTER
|| e
->ts
.type
== BT_DERIVED
)
1350 gfc_error ("By-value argument at %L is not of numeric "
1357 gfc_error ("By-value argument at %L cannot be an array or "
1358 "an array section", &e
->where
);
1362 /* Intrinsics are still PROC_UNKNOWN here. However,
1363 since same file external procedures are not resolvable
1364 in gfortran, it is a good deal easier to leave them to
1366 if (ptype
!= PROC_UNKNOWN
1367 && ptype
!= PROC_DUMMY
1368 && ptype
!= PROC_EXTERNAL
1369 && ptype
!= PROC_MODULE
)
1371 gfc_error ("By-value argument at %L is not allowed "
1372 "in this context", &e
->where
);
1377 /* Statement functions have already been excluded above. */
1378 else if (strncmp ("%LOC", arg
->name
, 4) == 0
1379 && e
->ts
.type
== BT_PROCEDURE
)
1381 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_INTERNAL
)
1383 gfc_error ("Passing internal procedure at %L by location "
1384 "not allowed", &e
->where
);
1395 /* Do the checks of the actual argument list that are specific to elemental
1396 procedures. If called with c == NULL, we have a function, otherwise if
1397 expr == NULL, we have a subroutine. */
1400 resolve_elemental_actual (gfc_expr
*expr
, gfc_code
*c
)
1402 gfc_actual_arglist
*arg0
;
1403 gfc_actual_arglist
*arg
;
1404 gfc_symbol
*esym
= NULL
;
1405 gfc_intrinsic_sym
*isym
= NULL
;
1407 gfc_intrinsic_arg
*iformal
= NULL
;
1408 gfc_formal_arglist
*eformal
= NULL
;
1409 bool formal_optional
= false;
1410 bool set_by_optional
= false;
1414 /* Is this an elemental procedure? */
1415 if (expr
&& expr
->value
.function
.actual
!= NULL
)
1417 if (expr
->value
.function
.esym
!= NULL
1418 && expr
->value
.function
.esym
->attr
.elemental
)
1420 arg0
= expr
->value
.function
.actual
;
1421 esym
= expr
->value
.function
.esym
;
1423 else if (expr
->value
.function
.isym
!= NULL
1424 && expr
->value
.function
.isym
->elemental
)
1426 arg0
= expr
->value
.function
.actual
;
1427 isym
= expr
->value
.function
.isym
;
1432 else if (c
&& c
->ext
.actual
!= NULL
)
1434 arg0
= c
->ext
.actual
;
1436 if (c
->resolved_sym
)
1437 esym
= c
->resolved_sym
;
1439 esym
= c
->symtree
->n
.sym
;
1442 if (!esym
->attr
.elemental
)
1448 /* The rank of an elemental is the rank of its array argument(s). */
1449 for (arg
= arg0
; arg
; arg
= arg
->next
)
1451 if (arg
->expr
!= NULL
&& arg
->expr
->rank
> 0)
1453 rank
= arg
->expr
->rank
;
1454 if (arg
->expr
->expr_type
== EXPR_VARIABLE
1455 && arg
->expr
->symtree
->n
.sym
->attr
.optional
)
1456 set_by_optional
= true;
1458 /* Function specific; set the result rank and shape. */
1462 if (!expr
->shape
&& arg
->expr
->shape
)
1464 expr
->shape
= gfc_get_shape (rank
);
1465 for (i
= 0; i
< rank
; i
++)
1466 mpz_init_set (expr
->shape
[i
], arg
->expr
->shape
[i
]);
1473 /* If it is an array, it shall not be supplied as an actual argument
1474 to an elemental procedure unless an array of the same rank is supplied
1475 as an actual argument corresponding to a nonoptional dummy argument of
1476 that elemental procedure(12.4.1.5). */
1477 formal_optional
= false;
1479 iformal
= isym
->formal
;
1481 eformal
= esym
->formal
;
1483 for (arg
= arg0
; arg
; arg
= arg
->next
)
1487 if (eformal
->sym
&& eformal
->sym
->attr
.optional
)
1488 formal_optional
= true;
1489 eformal
= eformal
->next
;
1491 else if (isym
&& iformal
)
1493 if (iformal
->optional
)
1494 formal_optional
= true;
1495 iformal
= iformal
->next
;
1498 formal_optional
= true;
1500 if (pedantic
&& arg
->expr
!= NULL
1501 && arg
->expr
->expr_type
== EXPR_VARIABLE
1502 && arg
->expr
->symtree
->n
.sym
->attr
.optional
1505 && (set_by_optional
|| arg
->expr
->rank
!= rank
)
1506 && !(isym
&& isym
->id
== GFC_ISYM_CONVERSION
))
1508 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1509 "MISSING, it cannot be the actual argument of an "
1510 "ELEMENTAL procedure unless there is a non-optional "
1511 "argument with the same rank (12.4.1.5)",
1512 arg
->expr
->symtree
->n
.sym
->name
, &arg
->expr
->where
);
1517 for (arg
= arg0
; arg
; arg
= arg
->next
)
1519 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
1522 /* Being elemental, the last upper bound of an assumed size array
1523 argument must be present. */
1524 if (resolve_assumed_size_actual (arg
->expr
))
1527 /* Elemental procedure's array actual arguments must conform. */
1530 if (gfc_check_conformance ("elemental procedure", arg
->expr
, e
)
1538 /* INTENT(OUT) is only allowed for subroutines; if any actual argument
1539 is an array, the intent inout/out variable needs to be also an array. */
1540 if (rank
> 0 && esym
&& expr
== NULL
)
1541 for (eformal
= esym
->formal
, arg
= arg0
; arg
&& eformal
;
1542 arg
= arg
->next
, eformal
= eformal
->next
)
1543 if ((eformal
->sym
->attr
.intent
== INTENT_OUT
1544 || eformal
->sym
->attr
.intent
== INTENT_INOUT
)
1545 && arg
->expr
&& arg
->expr
->rank
== 0)
1547 gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
1548 "ELEMENTAL subroutine '%s' is a scalar, but another "
1549 "actual argument is an array", &arg
->expr
->where
,
1550 (eformal
->sym
->attr
.intent
== INTENT_OUT
) ? "OUT"
1551 : "INOUT", eformal
->sym
->name
, esym
->name
);
1558 /* Go through each actual argument in ACTUAL and see if it can be
1559 implemented as an inlined, non-copying intrinsic. FNSYM is the
1560 function being called, or NULL if not known. */
1563 find_noncopying_intrinsics (gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
1565 gfc_actual_arglist
*ap
;
1568 for (ap
= actual
; ap
; ap
= ap
->next
)
1570 && (expr
= gfc_get_noncopying_intrinsic_argument (ap
->expr
))
1571 && !gfc_check_fncall_dependency (expr
, INTENT_IN
, fnsym
, actual
,
1573 ap
->expr
->inline_noncopying_intrinsic
= 1;
1577 /* This function does the checking of references to global procedures
1578 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1579 77 and 95 standards. It checks for a gsymbol for the name, making
1580 one if it does not already exist. If it already exists, then the
1581 reference being resolved must correspond to the type of gsymbol.
1582 Otherwise, the new symbol is equipped with the attributes of the
1583 reference. The corresponding code that is called in creating
1584 global entities is parse.c. */
1587 resolve_global_procedure (gfc_symbol
*sym
, locus
*where
, int sub
)
1592 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
1594 gsym
= gfc_get_gsymbol (sym
->name
);
1596 if ((gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= type
))
1597 gfc_global_used (gsym
, where
);
1599 if (gsym
->type
== GSYM_UNKNOWN
)
1602 gsym
->where
= *where
;
1609 /************* Function resolution *************/
1611 /* Resolve a function call known to be generic.
1612 Section 14.1.2.4.1. */
1615 resolve_generic_f0 (gfc_expr
*expr
, gfc_symbol
*sym
)
1619 if (sym
->attr
.generic
)
1621 s
= gfc_search_interface (sym
->generic
, 0, &expr
->value
.function
.actual
);
1624 expr
->value
.function
.name
= s
->name
;
1625 expr
->value
.function
.esym
= s
;
1627 if (s
->ts
.type
!= BT_UNKNOWN
)
1629 else if (s
->result
!= NULL
&& s
->result
->ts
.type
!= BT_UNKNOWN
)
1630 expr
->ts
= s
->result
->ts
;
1633 expr
->rank
= s
->as
->rank
;
1634 else if (s
->result
!= NULL
&& s
->result
->as
!= NULL
)
1635 expr
->rank
= s
->result
->as
->rank
;
1637 gfc_set_sym_referenced (expr
->value
.function
.esym
);
1642 /* TODO: Need to search for elemental references in generic
1646 if (sym
->attr
.intrinsic
)
1647 return gfc_intrinsic_func_interface (expr
, 0);
1654 resolve_generic_f (gfc_expr
*expr
)
1659 sym
= expr
->symtree
->n
.sym
;
1663 m
= resolve_generic_f0 (expr
, sym
);
1666 else if (m
== MATCH_ERROR
)
1670 if (sym
->ns
->parent
== NULL
)
1672 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1676 if (!generic_sym (sym
))
1680 /* Last ditch attempt. See if the reference is to an intrinsic
1681 that possesses a matching interface. 14.1.2.4 */
1682 if (sym
&& !gfc_is_intrinsic (sym
, 0, expr
->where
))
1684 gfc_error ("There is no specific function for the generic '%s' at %L",
1685 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1689 m
= gfc_intrinsic_func_interface (expr
, 0);
1693 gfc_error ("Generic function '%s' at %L is not consistent with a "
1694 "specific intrinsic interface", expr
->symtree
->n
.sym
->name
,
1701 /* Resolve a function call known to be specific. */
1704 resolve_specific_f0 (gfc_symbol
*sym
, gfc_expr
*expr
)
1708 /* See if we have an intrinsic interface. */
1710 if (sym
->ts
.interface
!= NULL
&& sym
->ts
.interface
->attr
.intrinsic
)
1712 gfc_intrinsic_sym
*isym
;
1713 isym
= gfc_find_function (sym
->ts
.interface
->name
);
1715 /* Existence of isym should be checked already. */
1718 sym
->ts
.type
= isym
->ts
.type
;
1719 sym
->ts
.kind
= isym
->ts
.kind
;
1720 sym
->attr
.function
= 1;
1721 sym
->attr
.proc
= PROC_EXTERNAL
;
1725 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
1727 if (sym
->attr
.dummy
)
1729 sym
->attr
.proc
= PROC_DUMMY
;
1733 sym
->attr
.proc
= PROC_EXTERNAL
;
1737 if (sym
->attr
.proc
== PROC_MODULE
1738 || sym
->attr
.proc
== PROC_ST_FUNCTION
1739 || sym
->attr
.proc
== PROC_INTERNAL
)
1742 if (sym
->attr
.intrinsic
)
1744 m
= gfc_intrinsic_func_interface (expr
, 1);
1748 gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
1749 "with an intrinsic", sym
->name
, &expr
->where
);
1757 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1760 expr
->value
.function
.name
= sym
->name
;
1761 expr
->value
.function
.esym
= sym
;
1762 if (sym
->as
!= NULL
)
1763 expr
->rank
= sym
->as
->rank
;
1770 resolve_specific_f (gfc_expr
*expr
)
1775 sym
= expr
->symtree
->n
.sym
;
1779 m
= resolve_specific_f0 (sym
, expr
);
1782 if (m
== MATCH_ERROR
)
1785 if (sym
->ns
->parent
== NULL
)
1788 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
1794 gfc_error ("Unable to resolve the specific function '%s' at %L",
1795 expr
->symtree
->n
.sym
->name
, &expr
->where
);
1801 /* Resolve a procedure call not known to be generic nor specific. */
1804 resolve_unknown_f (gfc_expr
*expr
)
1809 sym
= expr
->symtree
->n
.sym
;
1811 if (sym
->attr
.dummy
)
1813 sym
->attr
.proc
= PROC_DUMMY
;
1814 expr
->value
.function
.name
= sym
->name
;
1818 /* See if we have an intrinsic function reference. */
1820 if (gfc_is_intrinsic (sym
, 0, expr
->where
))
1822 if (gfc_intrinsic_func_interface (expr
, 1) == MATCH_YES
)
1827 /* The reference is to an external name. */
1829 sym
->attr
.proc
= PROC_EXTERNAL
;
1830 expr
->value
.function
.name
= sym
->name
;
1831 expr
->value
.function
.esym
= expr
->symtree
->n
.sym
;
1833 if (sym
->as
!= NULL
)
1834 expr
->rank
= sym
->as
->rank
;
1836 /* Type of the expression is either the type of the symbol or the
1837 default type of the symbol. */
1840 gfc_procedure_use (sym
, &expr
->value
.function
.actual
, &expr
->where
);
1842 if (sym
->ts
.type
!= BT_UNKNOWN
)
1846 ts
= gfc_get_default_type (sym
, sym
->ns
);
1848 if (ts
->type
== BT_UNKNOWN
)
1850 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1851 sym
->name
, &expr
->where
);
1862 /* Return true, if the symbol is an external procedure. */
1864 is_external_proc (gfc_symbol
*sym
)
1866 if (!sym
->attr
.dummy
&& !sym
->attr
.contained
1867 && !(sym
->attr
.intrinsic
1868 || gfc_is_intrinsic (sym
, sym
->attr
.subroutine
, sym
->declared_at
))
1869 && sym
->attr
.proc
!= PROC_ST_FUNCTION
1870 && !sym
->attr
.use_assoc
1878 /* Figure out if a function reference is pure or not. Also set the name
1879 of the function for a potential error message. Return nonzero if the
1880 function is PURE, zero if not. */
1882 pure_stmt_function (gfc_expr
*, gfc_symbol
*);
1885 pure_function (gfc_expr
*e
, const char **name
)
1891 if (e
->symtree
!= NULL
1892 && e
->symtree
->n
.sym
!= NULL
1893 && e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1894 return pure_stmt_function (e
, e
->symtree
->n
.sym
);
1896 if (e
->value
.function
.esym
)
1898 pure
= gfc_pure (e
->value
.function
.esym
);
1899 *name
= e
->value
.function
.esym
->name
;
1901 else if (e
->value
.function
.isym
)
1903 pure
= e
->value
.function
.isym
->pure
1904 || e
->value
.function
.isym
->elemental
;
1905 *name
= e
->value
.function
.isym
->name
;
1909 /* Implicit functions are not pure. */
1911 *name
= e
->value
.function
.name
;
1919 impure_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
,
1920 int *f ATTRIBUTE_UNUSED
)
1924 /* Don't bother recursing into other statement functions
1925 since they will be checked individually for purity. */
1926 if (e
->expr_type
!= EXPR_FUNCTION
1928 || e
->symtree
->n
.sym
== sym
1929 || e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
)
1932 return pure_function (e
, &name
) ? false : true;
1937 pure_stmt_function (gfc_expr
*e
, gfc_symbol
*sym
)
1939 return gfc_traverse_expr (e
, sym
, impure_stmt_fcn
, 0) ? 0 : 1;
1944 is_scalar_expr_ptr (gfc_expr
*expr
)
1946 gfc_try retval
= SUCCESS
;
1951 /* See if we have a gfc_ref, which means we have a substring, array
1952 reference, or a component. */
1953 if (expr
->ref
!= NULL
)
1956 while (ref
->next
!= NULL
)
1962 if (ref
->u
.ss
.length
!= NULL
1963 && ref
->u
.ss
.length
->length
!= NULL
1965 && ref
->u
.ss
.start
->expr_type
== EXPR_CONSTANT
1967 && ref
->u
.ss
.end
->expr_type
== EXPR_CONSTANT
)
1969 start
= (int) mpz_get_si (ref
->u
.ss
.start
->value
.integer
);
1970 end
= (int) mpz_get_si (ref
->u
.ss
.end
->value
.integer
);
1971 if (end
- start
+ 1 != 1)
1978 if (ref
->u
.ar
.type
== AR_ELEMENT
)
1980 else if (ref
->u
.ar
.type
== AR_FULL
)
1982 /* The user can give a full array if the array is of size 1. */
1983 if (ref
->u
.ar
.as
!= NULL
1984 && ref
->u
.ar
.as
->rank
== 1
1985 && ref
->u
.ar
.as
->type
== AS_EXPLICIT
1986 && ref
->u
.ar
.as
->lower
[0] != NULL
1987 && ref
->u
.ar
.as
->lower
[0]->expr_type
== EXPR_CONSTANT
1988 && ref
->u
.ar
.as
->upper
[0] != NULL
1989 && ref
->u
.ar
.as
->upper
[0]->expr_type
== EXPR_CONSTANT
)
1991 /* If we have a character string, we need to check if
1992 its length is one. */
1993 if (expr
->ts
.type
== BT_CHARACTER
)
1995 if (expr
->ts
.cl
== NULL
1996 || expr
->ts
.cl
->length
== NULL
1997 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1)
2003 /* We have constant lower and upper bounds. If the
2004 difference between is 1, it can be considered a
2006 start
= (int) mpz_get_si
2007 (ref
->u
.ar
.as
->lower
[0]->value
.integer
);
2008 end
= (int) mpz_get_si
2009 (ref
->u
.ar
.as
->upper
[0]->value
.integer
);
2010 if (end
- start
+ 1 != 1)
2025 else if (expr
->ts
.type
== BT_CHARACTER
&& expr
->rank
== 0)
2027 /* Character string. Make sure it's of length 1. */
2028 if (expr
->ts
.cl
== NULL
2029 || expr
->ts
.cl
->length
== NULL
2030 || mpz_cmp_si (expr
->ts
.cl
->length
->value
.integer
, 1) != 0)
2033 else if (expr
->rank
!= 0)
2040 /* Match one of the iso_c_binding functions (c_associated or c_loc)
2041 and, in the case of c_associated, set the binding label based on
2045 gfc_iso_c_func_interface (gfc_symbol
*sym
, gfc_actual_arglist
*args
,
2046 gfc_symbol
**new_sym
)
2048 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2049 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2050 int optional_arg
= 0, is_pointer
= 0;
2051 gfc_try retval
= SUCCESS
;
2052 gfc_symbol
*args_sym
;
2053 gfc_typespec
*arg_ts
;
2055 if (args
->expr
->expr_type
== EXPR_CONSTANT
2056 || args
->expr
->expr_type
== EXPR_OP
2057 || args
->expr
->expr_type
== EXPR_NULL
)
2059 gfc_error ("Argument to '%s' at %L is not a variable",
2060 sym
->name
, &(args
->expr
->where
));
2064 args_sym
= args
->expr
->symtree
->n
.sym
;
2066 /* The typespec for the actual arg should be that stored in the expr
2067 and not necessarily that of the expr symbol (args_sym), because
2068 the actual expression could be a part-ref of the expr symbol. */
2069 arg_ts
= &(args
->expr
->ts
);
2071 is_pointer
= gfc_is_data_pointer (args
->expr
);
2073 if (sym
->intmod_sym_id
== ISOCBINDING_ASSOCIATED
)
2075 /* If the user gave two args then they are providing something for
2076 the optional arg (the second cptr). Therefore, set the name and
2077 binding label to the c_associated for two cptrs. Otherwise,
2078 set c_associated to expect one cptr. */
2082 sprintf (name
, "%s_2", sym
->name
);
2083 sprintf (binding_label
, "%s_2", sym
->binding_label
);
2089 sprintf (name
, "%s_1", sym
->name
);
2090 sprintf (binding_label
, "%s_1", sym
->binding_label
);
2094 /* Get a new symbol for the version of c_associated that
2096 *new_sym
= get_iso_c_sym (sym
, name
, binding_label
, optional_arg
);
2098 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
2099 || sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2101 sprintf (name
, "%s", sym
->name
);
2102 sprintf (binding_label
, "%s", sym
->binding_label
);
2104 /* Error check the call. */
2105 if (args
->next
!= NULL
)
2107 gfc_error_now ("More actual than formal arguments in '%s' "
2108 "call at %L", name
, &(args
->expr
->where
));
2111 else if (sym
->intmod_sym_id
== ISOCBINDING_LOC
)
2113 /* Make sure we have either the target or pointer attribute. */
2114 if (!args_sym
->attr
.target
&& !is_pointer
)
2116 gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
2117 "a TARGET or an associated pointer",
2119 sym
->name
, &(args
->expr
->where
));
2123 /* See if we have interoperable type and type param. */
2124 if (verify_c_interop (arg_ts
) == SUCCESS
2125 || gfc_check_any_c_kind (arg_ts
) == SUCCESS
)
2127 if (args_sym
->attr
.target
== 1)
2129 /* Case 1a, section 15.1.2.5, J3/04-007: variable that
2130 has the target attribute and is interoperable. */
2131 /* Case 1b, section 15.1.2.5, J3/04-007: allocated
2132 allocatable variable that has the TARGET attribute and
2133 is not an array of zero size. */
2134 if (args_sym
->attr
.allocatable
== 1)
2136 if (args_sym
->attr
.dimension
!= 0
2137 && (args_sym
->as
&& args_sym
->as
->rank
== 0))
2139 gfc_error_now ("Allocatable variable '%s' used as a "
2140 "parameter to '%s' at %L must not be "
2141 "an array of zero size",
2142 args_sym
->name
, sym
->name
,
2143 &(args
->expr
->where
));
2149 /* A non-allocatable target variable with C
2150 interoperable type and type parameters must be
2152 if (args_sym
&& args_sym
->attr
.dimension
)
2154 if (args_sym
->as
->type
== AS_ASSUMED_SHAPE
)
2156 gfc_error ("Assumed-shape array '%s' at %L "
2157 "cannot be an argument to the "
2158 "procedure '%s' because "
2159 "it is not C interoperable",
2161 &(args
->expr
->where
), sym
->name
);
2164 else if (args_sym
->as
->type
== AS_DEFERRED
)
2166 gfc_error ("Deferred-shape array '%s' at %L "
2167 "cannot be an argument to the "
2168 "procedure '%s' because "
2169 "it is not C interoperable",
2171 &(args
->expr
->where
), sym
->name
);
2176 /* Make sure it's not a character string. Arrays of
2177 any type should be ok if the variable is of a C
2178 interoperable type. */
2179 if (arg_ts
->type
== BT_CHARACTER
)
2180 if (arg_ts
->cl
!= NULL
2181 && (arg_ts
->cl
->length
== NULL
2182 || arg_ts
->cl
->length
->expr_type
2185 (arg_ts
->cl
->length
->value
.integer
, 1)
2187 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2189 gfc_error_now ("CHARACTER argument '%s' to '%s' "
2190 "at %L must have a length of 1",
2191 args_sym
->name
, sym
->name
,
2192 &(args
->expr
->where
));
2198 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2200 /* Case 1c, section 15.1.2.5, J3/04-007: an associated
2202 gfc_error_now ("Argument '%s' to '%s' at %L must be an "
2203 "associated scalar POINTER", args_sym
->name
,
2204 sym
->name
, &(args
->expr
->where
));
2210 /* The parameter is not required to be C interoperable. If it
2211 is not C interoperable, it must be a nonpolymorphic scalar
2212 with no length type parameters. It still must have either
2213 the pointer or target attribute, and it can be
2214 allocatable (but must be allocated when c_loc is called). */
2215 if (args
->expr
->rank
!= 0
2216 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2218 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2219 "scalar", args_sym
->name
, sym
->name
,
2220 &(args
->expr
->where
));
2223 else if (arg_ts
->type
== BT_CHARACTER
2224 && is_scalar_expr_ptr (args
->expr
) != SUCCESS
)
2226 gfc_error_now ("CHARACTER argument '%s' to '%s' at "
2227 "%L must have a length of 1",
2228 args_sym
->name
, sym
->name
,
2229 &(args
->expr
->where
));
2234 else if (sym
->intmod_sym_id
== ISOCBINDING_FUNLOC
)
2236 if (args_sym
->attr
.flavor
!= FL_PROCEDURE
)
2238 /* TODO: Update this error message to allow for procedure
2239 pointers once they are implemented. */
2240 gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
2242 args_sym
->name
, sym
->name
,
2243 &(args
->expr
->where
));
2246 else if (args_sym
->attr
.is_bind_c
!= 1)
2248 gfc_error_now ("Parameter '%s' to '%s' at %L must be "
2250 args_sym
->name
, sym
->name
,
2251 &(args
->expr
->where
));
2256 /* for c_loc/c_funloc, the new symbol is the same as the old one */
2261 gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
2262 "iso_c_binding function: '%s'!\n", sym
->name
);
2269 /* Resolve a function call, which means resolving the arguments, then figuring
2270 out which entity the name refers to. */
2271 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
2272 to INTENT(OUT) or INTENT(INOUT). */
2275 resolve_function (gfc_expr
*expr
)
2277 gfc_actual_arglist
*arg
;
2282 procedure_type p
= PROC_INTRINSIC
;
2283 bool no_formal_args
;
2287 sym
= expr
->symtree
->n
.sym
;
2289 if (sym
&& sym
->attr
.intrinsic
2290 && !gfc_find_function (sym
->name
)
2291 && gfc_find_subroutine (sym
->name
)
2292 && sym
->attr
.function
)
2294 gfc_error ("Intrinsic subroutine '%s' used as "
2295 "a function at %L", sym
->name
, &expr
->where
);
2299 if (sym
&& (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.subroutine
))
2301 gfc_error ("'%s' at %L is not a function", sym
->name
, &expr
->where
);
2305 if (sym
&& sym
->attr
.abstract
)
2307 gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
2308 sym
->name
, &expr
->where
);
2312 /* If the procedure is external, check for usage. */
2313 if (sym
&& is_external_proc (sym
))
2314 resolve_global_procedure (sym
, &expr
->where
, 0);
2316 /* Switch off assumed size checking and do this again for certain kinds
2317 of procedure, once the procedure itself is resolved. */
2318 need_full_assumed_size
++;
2320 if (expr
->symtree
&& expr
->symtree
->n
.sym
)
2321 p
= expr
->symtree
->n
.sym
->attr
.proc
;
2323 no_formal_args
= sym
&& is_external_proc (sym
) && sym
->formal
== NULL
;
2324 if (resolve_actual_arglist (expr
->value
.function
.actual
,
2325 p
, no_formal_args
) == FAILURE
)
2328 /* Need to setup the call to the correct c_associated, depending on
2329 the number of cptrs to user gives to compare. */
2330 if (sym
&& sym
->attr
.is_iso_c
== 1)
2332 if (gfc_iso_c_func_interface (sym
, expr
->value
.function
.actual
, &sym
)
2336 /* Get the symtree for the new symbol (resolved func).
2337 the old one will be freed later, when it's no longer used. */
2338 gfc_find_sym_tree (sym
->name
, sym
->ns
, 1, &(expr
->symtree
));
2341 /* Resume assumed_size checking. */
2342 need_full_assumed_size
--;
2344 if (sym
&& sym
->ts
.type
== BT_CHARACTER
2346 && sym
->ts
.cl
->length
== NULL
2348 && expr
->value
.function
.esym
== NULL
2349 && !sym
->attr
.contained
)
2351 /* Internal procedures are taken care of in resolve_contained_fntype. */
2352 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
2353 "be used at %L since it is not a dummy argument",
2354 sym
->name
, &expr
->where
);
2358 /* See if function is already resolved. */
2360 if (expr
->value
.function
.name
!= NULL
)
2362 if (expr
->ts
.type
== BT_UNKNOWN
)
2368 /* Apply the rules of section 14.1.2. */
2370 switch (procedure_kind (sym
))
2373 t
= resolve_generic_f (expr
);
2376 case PTYPE_SPECIFIC
:
2377 t
= resolve_specific_f (expr
);
2381 t
= resolve_unknown_f (expr
);
2385 gfc_internal_error ("resolve_function(): bad function type");
2389 /* If the expression is still a function (it might have simplified),
2390 then we check to see if we are calling an elemental function. */
2392 if (expr
->expr_type
!= EXPR_FUNCTION
)
2395 temp
= need_full_assumed_size
;
2396 need_full_assumed_size
= 0;
2398 if (resolve_elemental_actual (expr
, NULL
) == FAILURE
)
2401 if (omp_workshare_flag
2402 && expr
->value
.function
.esym
2403 && ! gfc_elemental (expr
->value
.function
.esym
))
2405 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
2406 "in WORKSHARE construct", expr
->value
.function
.esym
->name
,
2411 #define GENERIC_ID expr->value.function.isym->id
2412 else if (expr
->value
.function
.actual
!= NULL
2413 && expr
->value
.function
.isym
!= NULL
2414 && GENERIC_ID
!= GFC_ISYM_LBOUND
2415 && GENERIC_ID
!= GFC_ISYM_LEN
2416 && GENERIC_ID
!= GFC_ISYM_LOC
2417 && GENERIC_ID
!= GFC_ISYM_PRESENT
)
2419 /* Array intrinsics must also have the last upper bound of an
2420 assumed size array argument. UBOUND and SIZE have to be
2421 excluded from the check if the second argument is anything
2424 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2426 if ((GENERIC_ID
== GFC_ISYM_UBOUND
|| GENERIC_ID
== GFC_ISYM_SIZE
)
2427 && arg
->next
!= NULL
&& arg
->next
->expr
)
2429 if (arg
->next
->expr
->expr_type
!= EXPR_CONSTANT
)
2432 if (arg
->next
->name
&& strncmp(arg
->next
->name
, "kind", 4) == 0)
2435 if ((int)mpz_get_si (arg
->next
->expr
->value
.integer
)
2440 if (arg
->expr
!= NULL
2441 && arg
->expr
->rank
> 0
2442 && resolve_assumed_size_actual (arg
->expr
))
2448 need_full_assumed_size
= temp
;
2451 if (!pure_function (expr
, &name
) && name
)
2455 gfc_error ("reference to non-PURE function '%s' at %L inside a "
2456 "FORALL %s", name
, &expr
->where
,
2457 forall_flag
== 2 ? "mask" : "block");
2460 else if (gfc_pure (NULL
))
2462 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
2463 "procedure within a PURE procedure", name
, &expr
->where
);
2468 /* Functions without the RECURSIVE attribution are not allowed to
2469 * call themselves. */
2470 if (expr
->value
.function
.esym
&& !expr
->value
.function
.esym
->attr
.recursive
)
2473 esym
= expr
->value
.function
.esym
;
2475 if (is_illegal_recursion (esym
, gfc_current_ns
))
2477 if (esym
->attr
.entry
&& esym
->ns
->entries
)
2478 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2479 " function '%s' is not RECURSIVE",
2480 esym
->name
, &expr
->where
, esym
->ns
->entries
->sym
->name
);
2482 gfc_error ("Function '%s' at %L cannot be called recursively, as it"
2483 " is not RECURSIVE", esym
->name
, &expr
->where
);
2489 /* Character lengths of use associated functions may contains references to
2490 symbols not referenced from the current program unit otherwise. Make sure
2491 those symbols are marked as referenced. */
2493 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->value
.function
.esym
2494 && expr
->value
.function
.esym
->attr
.use_assoc
)
2496 gfc_expr_set_symbols_referenced (expr
->ts
.cl
->length
);
2500 && !((expr
->value
.function
.esym
2501 && expr
->value
.function
.esym
->attr
.elemental
)
2503 (expr
->value
.function
.isym
2504 && expr
->value
.function
.isym
->elemental
)))
2505 find_noncopying_intrinsics (expr
->value
.function
.esym
,
2506 expr
->value
.function
.actual
);
2508 /* Make sure that the expression has a typespec that works. */
2509 if (expr
->ts
.type
== BT_UNKNOWN
)
2511 if (expr
->symtree
->n
.sym
->result
2512 && expr
->symtree
->n
.sym
->result
->ts
.type
!= BT_UNKNOWN
)
2513 expr
->ts
= expr
->symtree
->n
.sym
->result
->ts
;
2520 /************* Subroutine resolution *************/
2523 pure_subroutine (gfc_code
*c
, gfc_symbol
*sym
)
2529 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
2530 sym
->name
, &c
->loc
);
2531 else if (gfc_pure (NULL
))
2532 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym
->name
,
2538 resolve_generic_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2542 if (sym
->attr
.generic
)
2544 s
= gfc_search_interface (sym
->generic
, 1, &c
->ext
.actual
);
2547 c
->resolved_sym
= s
;
2548 pure_subroutine (c
, s
);
2552 /* TODO: Need to search for elemental references in generic interface. */
2555 if (sym
->attr
.intrinsic
)
2556 return gfc_intrinsic_sub_interface (c
, 0);
2563 resolve_generic_s (gfc_code
*c
)
2568 sym
= c
->symtree
->n
.sym
;
2572 m
= resolve_generic_s0 (c
, sym
);
2575 else if (m
== MATCH_ERROR
)
2579 if (sym
->ns
->parent
== NULL
)
2581 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2585 if (!generic_sym (sym
))
2589 /* Last ditch attempt. See if the reference is to an intrinsic
2590 that possesses a matching interface. 14.1.2.4 */
2591 sym
= c
->symtree
->n
.sym
;
2593 if (!gfc_is_intrinsic (sym
, 1, c
->loc
))
2595 gfc_error ("There is no specific subroutine for the generic '%s' at %L",
2596 sym
->name
, &c
->loc
);
2600 m
= gfc_intrinsic_sub_interface (c
, 0);
2604 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
2605 "intrinsic subroutine interface", sym
->name
, &c
->loc
);
2611 /* Set the name and binding label of the subroutine symbol in the call
2612 expression represented by 'c' to include the type and kind of the
2613 second parameter. This function is for resolving the appropriate
2614 version of c_f_pointer() and c_f_procpointer(). For example, a
2615 call to c_f_pointer() for a default integer pointer could have a
2616 name of c_f_pointer_i4. If no second arg exists, which is an error
2617 for these two functions, it defaults to the generic symbol's name
2618 and binding label. */
2621 set_name_and_label (gfc_code
*c
, gfc_symbol
*sym
,
2622 char *name
, char *binding_label
)
2624 gfc_expr
*arg
= NULL
;
2628 /* The second arg of c_f_pointer and c_f_procpointer determines
2629 the type and kind for the procedure name. */
2630 arg
= c
->ext
.actual
->next
->expr
;
2634 /* Set up the name to have the given symbol's name,
2635 plus the type and kind. */
2636 /* a derived type is marked with the type letter 'u' */
2637 if (arg
->ts
.type
== BT_DERIVED
)
2640 kind
= 0; /* set the kind as 0 for now */
2644 type
= gfc_type_letter (arg
->ts
.type
);
2645 kind
= arg
->ts
.kind
;
2648 if (arg
->ts
.type
== BT_CHARACTER
)
2649 /* Kind info for character strings not needed. */
2652 sprintf (name
, "%s_%c%d", sym
->name
, type
, kind
);
2653 /* Set up the binding label as the given symbol's label plus
2654 the type and kind. */
2655 sprintf (binding_label
, "%s_%c%d", sym
->binding_label
, type
, kind
);
2659 /* If the second arg is missing, set the name and label as
2660 was, cause it should at least be found, and the missing
2661 arg error will be caught by compare_parameters(). */
2662 sprintf (name
, "%s", sym
->name
);
2663 sprintf (binding_label
, "%s", sym
->binding_label
);
2670 /* Resolve a generic version of the iso_c_binding procedure given
2671 (sym) to the specific one based on the type and kind of the
2672 argument(s). Currently, this function resolves c_f_pointer() and
2673 c_f_procpointer based on the type and kind of the second argument
2674 (FPTR). Other iso_c_binding procedures aren't specially handled.
2675 Upon successfully exiting, c->resolved_sym will hold the resolved
2676 symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
2680 gfc_iso_c_sub_interface (gfc_code
*c
, gfc_symbol
*sym
)
2682 gfc_symbol
*new_sym
;
2683 /* this is fine, since we know the names won't use the max */
2684 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2685 char binding_label
[GFC_MAX_BINDING_LABEL_LEN
+ 1];
2686 /* default to success; will override if find error */
2687 match m
= MATCH_YES
;
2689 /* Make sure the actual arguments are in the necessary order (based on the
2690 formal args) before resolving. */
2691 gfc_procedure_use (sym
, &c
->ext
.actual
, &(c
->loc
));
2693 if ((sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
) ||
2694 (sym
->intmod_sym_id
== ISOCBINDING_F_PROCPOINTER
))
2696 set_name_and_label (c
, sym
, name
, binding_label
);
2698 if (sym
->intmod_sym_id
== ISOCBINDING_F_POINTER
)
2700 if (c
->ext
.actual
!= NULL
&& c
->ext
.actual
->next
!= NULL
)
2702 /* Make sure we got a third arg if the second arg has non-zero
2703 rank. We must also check that the type and rank are
2704 correct since we short-circuit this check in
2705 gfc_procedure_use() (called above to sort actual args). */
2706 if (c
->ext
.actual
->next
->expr
->rank
!= 0)
2708 if(c
->ext
.actual
->next
->next
== NULL
2709 || c
->ext
.actual
->next
->next
->expr
== NULL
)
2712 gfc_error ("Missing SHAPE parameter for call to %s "
2713 "at %L", sym
->name
, &(c
->loc
));
2715 else if (c
->ext
.actual
->next
->next
->expr
->ts
.type
2717 || c
->ext
.actual
->next
->next
->expr
->rank
!= 1)
2720 gfc_error ("SHAPE parameter for call to %s at %L must "
2721 "be a rank 1 INTEGER array", sym
->name
,
2728 if (m
!= MATCH_ERROR
)
2730 /* the 1 means to add the optional arg to formal list */
2731 new_sym
= get_iso_c_sym (sym
, name
, binding_label
, 1);
2733 /* for error reporting, say it's declared where the original was */
2734 new_sym
->declared_at
= sym
->declared_at
;
2739 /* no differences for c_loc or c_funloc */
2743 /* set the resolved symbol */
2744 if (m
!= MATCH_ERROR
)
2745 c
->resolved_sym
= new_sym
;
2747 c
->resolved_sym
= sym
;
2753 /* Resolve a subroutine call known to be specific. */
2756 resolve_specific_s0 (gfc_code
*c
, gfc_symbol
*sym
)
2760 /* See if we have an intrinsic interface. */
2761 if (sym
->ts
.interface
!= NULL
&& !sym
->ts
.interface
->attr
.abstract
2762 && !sym
->ts
.interface
->attr
.subroutine
2763 && sym
->ts
.interface
->attr
.intrinsic
)
2765 gfc_intrinsic_sym
*isym
;
2767 isym
= gfc_find_function (sym
->ts
.interface
->name
);
2769 /* Existence of isym should be checked already. */
2772 sym
->ts
.type
= isym
->ts
.type
;
2773 sym
->ts
.kind
= isym
->ts
.kind
;
2774 sym
->attr
.subroutine
= 1;
2778 if(sym
->attr
.is_iso_c
)
2780 m
= gfc_iso_c_sub_interface (c
,sym
);
2784 if (sym
->attr
.external
|| sym
->attr
.if_source
== IFSRC_IFBODY
)
2786 if (sym
->attr
.dummy
)
2788 sym
->attr
.proc
= PROC_DUMMY
;
2792 sym
->attr
.proc
= PROC_EXTERNAL
;
2796 if (sym
->attr
.proc
== PROC_MODULE
|| sym
->attr
.proc
== PROC_INTERNAL
)
2799 if (sym
->attr
.intrinsic
)
2801 m
= gfc_intrinsic_sub_interface (c
, 1);
2805 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
2806 "with an intrinsic", sym
->name
, &c
->loc
);
2814 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2816 c
->resolved_sym
= sym
;
2817 pure_subroutine (c
, sym
);
2824 resolve_specific_s (gfc_code
*c
)
2829 sym
= c
->symtree
->n
.sym
;
2833 m
= resolve_specific_s0 (c
, sym
);
2836 if (m
== MATCH_ERROR
)
2839 if (sym
->ns
->parent
== NULL
)
2842 gfc_find_symbol (sym
->name
, sym
->ns
->parent
, 1, &sym
);
2848 sym
= c
->symtree
->n
.sym
;
2849 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
2850 sym
->name
, &c
->loc
);
2856 /* Resolve a subroutine call not known to be generic nor specific. */
2859 resolve_unknown_s (gfc_code
*c
)
2863 sym
= c
->symtree
->n
.sym
;
2865 if (sym
->attr
.dummy
)
2867 sym
->attr
.proc
= PROC_DUMMY
;
2871 /* See if we have an intrinsic function reference. */
2873 if (gfc_is_intrinsic (sym
, 1, c
->loc
))
2875 if (gfc_intrinsic_sub_interface (c
, 1) == MATCH_YES
)
2880 /* The reference is to an external name. */
2883 gfc_procedure_use (sym
, &c
->ext
.actual
, &c
->loc
);
2885 c
->resolved_sym
= sym
;
2887 pure_subroutine (c
, sym
);
2893 /* Resolve a subroutine call. Although it was tempting to use the same code
2894 for functions, subroutines and functions are stored differently and this
2895 makes things awkward. */
2898 resolve_call (gfc_code
*c
)
2901 procedure_type ptype
= PROC_INTRINSIC
;
2902 gfc_symbol
*csym
, *sym
;
2903 bool no_formal_args
;
2905 csym
= c
->symtree
? c
->symtree
->n
.sym
: NULL
;
2907 if (csym
&& csym
->ts
.type
!= BT_UNKNOWN
)
2909 gfc_error ("'%s' at %L has a type, which is not consistent with "
2910 "the CALL at %L", csym
->name
, &csym
->declared_at
, &c
->loc
);
2914 if (csym
&& gfc_current_ns
->parent
&& csym
->ns
!= gfc_current_ns
)
2917 gfc_find_sym_tree (csym
->name
, gfc_current_ns
, 1, &st
);
2918 sym
= st
? st
->n
.sym
: NULL
;
2919 if (sym
&& csym
!= sym
2920 && sym
->ns
== gfc_current_ns
2921 && sym
->attr
.flavor
== FL_PROCEDURE
2922 && sym
->attr
.contained
)
2925 if (csym
->attr
.generic
)
2926 c
->symtree
->n
.sym
= sym
;
2929 csym
= c
->symtree
->n
.sym
;
2933 /* If external, check for usage. */
2934 if (csym
&& is_external_proc (csym
))
2935 resolve_global_procedure (csym
, &c
->loc
, 1);
2937 /* Subroutines without the RECURSIVE attribution are not allowed to
2938 * call themselves. */
2939 if (csym
&& is_illegal_recursion (csym
, gfc_current_ns
))
2941 if (csym
->attr
.entry
&& csym
->ns
->entries
)
2942 gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
2943 " subroutine '%s' is not RECURSIVE",
2944 csym
->name
, &c
->loc
, csym
->ns
->entries
->sym
->name
);
2946 gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
2947 " is not RECURSIVE", csym
->name
, &c
->loc
);
2952 /* Switch off assumed size checking and do this again for certain kinds
2953 of procedure, once the procedure itself is resolved. */
2954 need_full_assumed_size
++;
2957 ptype
= csym
->attr
.proc
;
2959 no_formal_args
= csym
&& is_external_proc (csym
) && csym
->formal
== NULL
;
2960 if (resolve_actual_arglist (c
->ext
.actual
, ptype
,
2961 no_formal_args
) == FAILURE
)
2964 /* Resume assumed_size checking. */
2965 need_full_assumed_size
--;
2968 if (c
->resolved_sym
== NULL
)
2970 c
->resolved_isym
= NULL
;
2971 switch (procedure_kind (csym
))
2974 t
= resolve_generic_s (c
);
2977 case PTYPE_SPECIFIC
:
2978 t
= resolve_specific_s (c
);
2982 t
= resolve_unknown_s (c
);
2986 gfc_internal_error ("resolve_subroutine(): bad function type");
2990 /* Some checks of elemental subroutine actual arguments. */
2991 if (resolve_elemental_actual (NULL
, c
) == FAILURE
)
2994 if (t
== SUCCESS
&& !(c
->resolved_sym
&& c
->resolved_sym
->attr
.elemental
))
2995 find_noncopying_intrinsics (c
->resolved_sym
, c
->ext
.actual
);
3000 /* Compare the shapes of two arrays that have non-NULL shapes. If both
3001 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
3002 match. If both op1->shape and op2->shape are non-NULL return FAILURE
3003 if their shapes do not match. If either op1->shape or op2->shape is
3004 NULL, return SUCCESS. */
3007 compare_shapes (gfc_expr
*op1
, gfc_expr
*op2
)
3014 if (op1
->shape
!= NULL
&& op2
->shape
!= NULL
)
3016 for (i
= 0; i
< op1
->rank
; i
++)
3018 if (mpz_cmp (op1
->shape
[i
], op2
->shape
[i
]) != 0)
3020 gfc_error ("Shapes for operands at %L and %L are not conformable",
3021 &op1
->where
, &op2
->where
);
3032 /* Resolve an operator expression node. This can involve replacing the
3033 operation with a user defined function call. */
3036 resolve_operator (gfc_expr
*e
)
3038 gfc_expr
*op1
, *op2
;
3040 bool dual_locus_error
;
3043 /* Resolve all subnodes-- give them types. */
3045 switch (e
->value
.op
.op
)
3048 if (gfc_resolve_expr (e
->value
.op
.op2
) == FAILURE
)
3051 /* Fall through... */
3054 case INTRINSIC_UPLUS
:
3055 case INTRINSIC_UMINUS
:
3056 case INTRINSIC_PARENTHESES
:
3057 if (gfc_resolve_expr (e
->value
.op
.op1
) == FAILURE
)
3062 /* Typecheck the new node. */
3064 op1
= e
->value
.op
.op1
;
3065 op2
= e
->value
.op
.op2
;
3066 dual_locus_error
= false;
3068 if ((op1
&& op1
->expr_type
== EXPR_NULL
)
3069 || (op2
&& op2
->expr_type
== EXPR_NULL
))
3071 sprintf (msg
, _("Invalid context for NULL() pointer at %%L"));
3075 switch (e
->value
.op
.op
)
3077 case INTRINSIC_UPLUS
:
3078 case INTRINSIC_UMINUS
:
3079 if (op1
->ts
.type
== BT_INTEGER
3080 || op1
->ts
.type
== BT_REAL
3081 || op1
->ts
.type
== BT_COMPLEX
)
3087 sprintf (msg
, _("Operand of unary numeric operator '%s' at %%L is %s"),
3088 gfc_op2string (e
->value
.op
.op
), gfc_typename (&e
->ts
));
3091 case INTRINSIC_PLUS
:
3092 case INTRINSIC_MINUS
:
3093 case INTRINSIC_TIMES
:
3094 case INTRINSIC_DIVIDE
:
3095 case INTRINSIC_POWER
:
3096 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3098 gfc_type_convert_binary (e
);
3103 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
3104 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3105 gfc_typename (&op2
->ts
));
3108 case INTRINSIC_CONCAT
:
3109 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3110 && op1
->ts
.kind
== op2
->ts
.kind
)
3112 e
->ts
.type
= BT_CHARACTER
;
3113 e
->ts
.kind
= op1
->ts
.kind
;
3118 _("Operands of string concatenation operator at %%L are %s/%s"),
3119 gfc_typename (&op1
->ts
), gfc_typename (&op2
->ts
));
3125 case INTRINSIC_NEQV
:
3126 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3128 e
->ts
.type
= BT_LOGICAL
;
3129 e
->ts
.kind
= gfc_kind_max (op1
, op2
);
3130 if (op1
->ts
.kind
< e
->ts
.kind
)
3131 gfc_convert_type (op1
, &e
->ts
, 2);
3132 else if (op2
->ts
.kind
< e
->ts
.kind
)
3133 gfc_convert_type (op2
, &e
->ts
, 2);
3137 sprintf (msg
, _("Operands of logical operator '%s' at %%L are %s/%s"),
3138 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3139 gfc_typename (&op2
->ts
));
3144 if (op1
->ts
.type
== BT_LOGICAL
)
3146 e
->ts
.type
= BT_LOGICAL
;
3147 e
->ts
.kind
= op1
->ts
.kind
;
3151 sprintf (msg
, _("Operand of .not. operator at %%L is %s"),
3152 gfc_typename (&op1
->ts
));
3156 case INTRINSIC_GT_OS
:
3158 case INTRINSIC_GE_OS
:
3160 case INTRINSIC_LT_OS
:
3162 case INTRINSIC_LE_OS
:
3163 if (op1
->ts
.type
== BT_COMPLEX
|| op2
->ts
.type
== BT_COMPLEX
)
3165 strcpy (msg
, _("COMPLEX quantities cannot be compared at %L"));
3169 /* Fall through... */
3172 case INTRINSIC_EQ_OS
:
3174 case INTRINSIC_NE_OS
:
3175 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
3176 && op1
->ts
.kind
== op2
->ts
.kind
)
3178 e
->ts
.type
= BT_LOGICAL
;
3179 e
->ts
.kind
= gfc_default_logical_kind
;
3183 if (gfc_numeric_ts (&op1
->ts
) && gfc_numeric_ts (&op2
->ts
))
3185 gfc_type_convert_binary (e
);
3187 e
->ts
.type
= BT_LOGICAL
;
3188 e
->ts
.kind
= gfc_default_logical_kind
;
3192 if (op1
->ts
.type
== BT_LOGICAL
&& op2
->ts
.type
== BT_LOGICAL
)
3194 _("Logicals at %%L must be compared with %s instead of %s"),
3195 (e
->value
.op
.op
== INTRINSIC_EQ
3196 || e
->value
.op
.op
== INTRINSIC_EQ_OS
)
3197 ? ".eqv." : ".neqv.", gfc_op2string (e
->value
.op
.op
));
3200 _("Operands of comparison operator '%s' at %%L are %s/%s"),
3201 gfc_op2string (e
->value
.op
.op
), gfc_typename (&op1
->ts
),
3202 gfc_typename (&op2
->ts
));
3206 case INTRINSIC_USER
:
3207 if (e
->value
.op
.uop
->op
== NULL
)
3208 sprintf (msg
, _("Unknown operator '%s' at %%L"), e
->value
.op
.uop
->name
);
3209 else if (op2
== NULL
)
3210 sprintf (msg
, _("Operand of user operator '%s' at %%L is %s"),
3211 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
));
3213 sprintf (msg
, _("Operands of user operator '%s' at %%L are %s/%s"),
3214 e
->value
.op
.uop
->name
, gfc_typename (&op1
->ts
),
3215 gfc_typename (&op2
->ts
));
3219 case INTRINSIC_PARENTHESES
:
3221 if (e
->ts
.type
== BT_CHARACTER
)
3222 e
->ts
.cl
= op1
->ts
.cl
;
3226 gfc_internal_error ("resolve_operator(): Bad intrinsic");
3229 /* Deal with arrayness of an operand through an operator. */
3233 switch (e
->value
.op
.op
)
3235 case INTRINSIC_PLUS
:
3236 case INTRINSIC_MINUS
:
3237 case INTRINSIC_TIMES
:
3238 case INTRINSIC_DIVIDE
:
3239 case INTRINSIC_POWER
:
3240 case INTRINSIC_CONCAT
:
3244 case INTRINSIC_NEQV
:
3246 case INTRINSIC_EQ_OS
:
3248 case INTRINSIC_NE_OS
:
3250 case INTRINSIC_GT_OS
:
3252 case INTRINSIC_GE_OS
:
3254 case INTRINSIC_LT_OS
:
3256 case INTRINSIC_LE_OS
:
3258 if (op1
->rank
== 0 && op2
->rank
== 0)
3261 if (op1
->rank
== 0 && op2
->rank
!= 0)
3263 e
->rank
= op2
->rank
;
3265 if (e
->shape
== NULL
)
3266 e
->shape
= gfc_copy_shape (op2
->shape
, op2
->rank
);
3269 if (op1
->rank
!= 0 && op2
->rank
== 0)
3271 e
->rank
= op1
->rank
;
3273 if (e
->shape
== NULL
)
3274 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3277 if (op1
->rank
!= 0 && op2
->rank
!= 0)
3279 if (op1
->rank
== op2
->rank
)
3281 e
->rank
= op1
->rank
;
3282 if (e
->shape
== NULL
)
3284 t
= compare_shapes(op1
, op2
);
3288 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3293 /* Allow higher level expressions to work. */
3296 /* Try user-defined operators, and otherwise throw an error. */
3297 dual_locus_error
= true;
3299 _("Inconsistent ranks for operator at %%L and %%L"));
3306 case INTRINSIC_PARENTHESES
:
3308 case INTRINSIC_UPLUS
:
3309 case INTRINSIC_UMINUS
:
3310 /* Simply copy arrayness attribute */
3311 e
->rank
= op1
->rank
;
3313 if (e
->shape
== NULL
)
3314 e
->shape
= gfc_copy_shape (op1
->shape
, op1
->rank
);
3322 /* Attempt to simplify the expression. */
3325 t
= gfc_simplify_expr (e
, 0);
3326 /* Some calls do not succeed in simplification and return FAILURE
3327 even though there is no error; e.g. variable references to
3328 PARAMETER arrays. */
3329 if (!gfc_is_constant_expr (e
))
3336 if (gfc_extend_expr (e
) == SUCCESS
)
3339 if (dual_locus_error
)
3340 gfc_error (msg
, &op1
->where
, &op2
->where
);
3342 gfc_error (msg
, &e
->where
);
3348 /************** Array resolution subroutines **************/
3351 { CMP_LT
, CMP_EQ
, CMP_GT
, CMP_UNKNOWN
}
3354 /* Compare two integer expressions. */
3357 compare_bound (gfc_expr
*a
, gfc_expr
*b
)
3361 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
3362 || b
== NULL
|| b
->expr_type
!= EXPR_CONSTANT
)
3365 /* If either of the types isn't INTEGER, we must have
3366 raised an error earlier. */
3368 if (a
->ts
.type
!= BT_INTEGER
|| b
->ts
.type
!= BT_INTEGER
)
3371 i
= mpz_cmp (a
->value
.integer
, b
->value
.integer
);
3381 /* Compare an integer expression with an integer. */
3384 compare_bound_int (gfc_expr
*a
, int b
)
3388 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3391 if (a
->ts
.type
!= BT_INTEGER
)
3392 gfc_internal_error ("compare_bound_int(): Bad expression");
3394 i
= mpz_cmp_si (a
->value
.integer
, b
);
3404 /* Compare an integer expression with a mpz_t. */
3407 compare_bound_mpz_t (gfc_expr
*a
, mpz_t b
)
3411 if (a
== NULL
|| a
->expr_type
!= EXPR_CONSTANT
)
3414 if (a
->ts
.type
!= BT_INTEGER
)
3415 gfc_internal_error ("compare_bound_int(): Bad expression");
3417 i
= mpz_cmp (a
->value
.integer
, b
);
3427 /* Compute the last value of a sequence given by a triplet.
3428 Return 0 if it wasn't able to compute the last value, or if the
3429 sequence if empty, and 1 otherwise. */
3432 compute_last_value_for_triplet (gfc_expr
*start
, gfc_expr
*end
,
3433 gfc_expr
*stride
, mpz_t last
)
3437 if (start
== NULL
|| start
->expr_type
!= EXPR_CONSTANT
3438 || end
== NULL
|| end
->expr_type
!= EXPR_CONSTANT
3439 || (stride
!= NULL
&& stride
->expr_type
!= EXPR_CONSTANT
))
3442 if (start
->ts
.type
!= BT_INTEGER
|| end
->ts
.type
!= BT_INTEGER
3443 || (stride
!= NULL
&& stride
->ts
.type
!= BT_INTEGER
))
3446 if (stride
== NULL
|| compare_bound_int(stride
, 1) == CMP_EQ
)
3448 if (compare_bound (start
, end
) == CMP_GT
)
3450 mpz_set (last
, end
->value
.integer
);
3454 if (compare_bound_int (stride
, 0) == CMP_GT
)
3456 /* Stride is positive */
3457 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) > 0)
3462 /* Stride is negative */
3463 if (mpz_cmp (start
->value
.integer
, end
->value
.integer
) < 0)
3468 mpz_sub (rem
, end
->value
.integer
, start
->value
.integer
);
3469 mpz_tdiv_r (rem
, rem
, stride
->value
.integer
);
3470 mpz_sub (last
, end
->value
.integer
, rem
);
3477 /* Compare a single dimension of an array reference to the array
3481 check_dimension (int i
, gfc_array_ref
*ar
, gfc_array_spec
*as
)
3485 /* Given start, end and stride values, calculate the minimum and
3486 maximum referenced indexes. */
3488 switch (ar
->dimen_type
[i
])
3494 if (compare_bound (ar
->start
[i
], as
->lower
[i
]) == CMP_LT
)
3496 gfc_warning ("Array reference at %L is out of bounds "
3497 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3498 mpz_get_si (ar
->start
[i
]->value
.integer
),
3499 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3502 if (compare_bound (ar
->start
[i
], as
->upper
[i
]) == CMP_GT
)
3504 gfc_warning ("Array reference at %L is out of bounds "
3505 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3506 mpz_get_si (ar
->start
[i
]->value
.integer
),
3507 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3515 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
3516 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
3518 comparison comp_start_end
= compare_bound (AR_START
, AR_END
);
3520 /* Check for zero stride, which is not allowed. */
3521 if (compare_bound_int (ar
->stride
[i
], 0) == CMP_EQ
)
3523 gfc_error ("Illegal stride of zero at %L", &ar
->c_where
[i
]);
3527 /* if start == len || (stride > 0 && start < len)
3528 || (stride < 0 && start > len),
3529 then the array section contains at least one element. In this
3530 case, there is an out-of-bounds access if
3531 (start < lower || start > upper). */
3532 if (compare_bound (AR_START
, AR_END
) == CMP_EQ
3533 || ((compare_bound_int (ar
->stride
[i
], 0) == CMP_GT
3534 || ar
->stride
[i
] == NULL
) && comp_start_end
== CMP_LT
)
3535 || (compare_bound_int (ar
->stride
[i
], 0) == CMP_LT
3536 && comp_start_end
== CMP_GT
))
3538 if (compare_bound (AR_START
, as
->lower
[i
]) == CMP_LT
)
3540 gfc_warning ("Lower array reference at %L is out of bounds "
3541 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3542 mpz_get_si (AR_START
->value
.integer
),
3543 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3546 if (compare_bound (AR_START
, as
->upper
[i
]) == CMP_GT
)
3548 gfc_warning ("Lower array reference at %L is out of bounds "
3549 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3550 mpz_get_si (AR_START
->value
.integer
),
3551 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3556 /* If we can compute the highest index of the array section,
3557 then it also has to be between lower and upper. */
3558 mpz_init (last_value
);
3559 if (compute_last_value_for_triplet (AR_START
, AR_END
, ar
->stride
[i
],
3562 if (compare_bound_mpz_t (as
->lower
[i
], last_value
) == CMP_GT
)
3564 gfc_warning ("Upper array reference at %L is out of bounds "
3565 "(%ld < %ld) in dimension %d", &ar
->c_where
[i
],
3566 mpz_get_si (last_value
),
3567 mpz_get_si (as
->lower
[i
]->value
.integer
), i
+1);
3568 mpz_clear (last_value
);
3571 if (compare_bound_mpz_t (as
->upper
[i
], last_value
) == CMP_LT
)
3573 gfc_warning ("Upper array reference at %L is out of bounds "
3574 "(%ld > %ld) in dimension %d", &ar
->c_where
[i
],
3575 mpz_get_si (last_value
),
3576 mpz_get_si (as
->upper
[i
]->value
.integer
), i
+1);
3577 mpz_clear (last_value
);
3581 mpz_clear (last_value
);
3589 gfc_internal_error ("check_dimension(): Bad array reference");
3596 /* Compare an array reference with an array specification. */
3599 compare_spec_to_ref (gfc_array_ref
*ar
)
3606 /* TODO: Full array sections are only allowed as actual parameters. */
3607 if (as
->type
== AS_ASSUMED_SIZE
3608 && (/*ar->type == AR_FULL
3609 ||*/ (ar
->type
== AR_SECTION
3610 && ar
->dimen_type
[i
] == DIMEN_RANGE
&& ar
->end
[i
] == NULL
)))
3612 gfc_error ("Rightmost upper bound of assumed size array section "
3613 "not specified at %L", &ar
->where
);
3617 if (ar
->type
== AR_FULL
)
3620 if (as
->rank
!= ar
->dimen
)
3622 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
3623 &ar
->where
, ar
->dimen
, as
->rank
);
3627 for (i
= 0; i
< as
->rank
; i
++)
3628 if (check_dimension (i
, ar
, as
) == FAILURE
)
3635 /* Resolve one part of an array index. */
3638 gfc_resolve_index (gfc_expr
*index
, int check_scalar
)
3645 if (gfc_resolve_expr (index
) == FAILURE
)
3648 if (check_scalar
&& index
->rank
!= 0)
3650 gfc_error ("Array index at %L must be scalar", &index
->where
);
3654 if (index
->ts
.type
!= BT_INTEGER
&& index
->ts
.type
!= BT_REAL
)
3656 gfc_error ("Array index at %L must be of INTEGER type, found %s",
3657 &index
->where
, gfc_basic_typename (index
->ts
.type
));
3661 if (index
->ts
.type
== BT_REAL
)
3662 if (gfc_notify_std (GFC_STD_LEGACY
, "Extension: REAL array index at %L",
3663 &index
->where
) == FAILURE
)
3666 if (index
->ts
.kind
!= gfc_index_integer_kind
3667 || index
->ts
.type
!= BT_INTEGER
)
3670 ts
.type
= BT_INTEGER
;
3671 ts
.kind
= gfc_index_integer_kind
;
3673 gfc_convert_type_warn (index
, &ts
, 2, 0);
3679 /* Resolve a dim argument to an intrinsic function. */
3682 gfc_resolve_dim_arg (gfc_expr
*dim
)
3687 if (gfc_resolve_expr (dim
) == FAILURE
)
3692 gfc_error ("Argument dim at %L must be scalar", &dim
->where
);
3697 if (dim
->ts
.type
!= BT_INTEGER
)
3699 gfc_error ("Argument dim at %L must be of INTEGER type", &dim
->where
);
3703 if (dim
->ts
.kind
!= gfc_index_integer_kind
)
3707 ts
.type
= BT_INTEGER
;
3708 ts
.kind
= gfc_index_integer_kind
;
3710 gfc_convert_type_warn (dim
, &ts
, 2, 0);
3716 /* Given an expression that contains array references, update those array
3717 references to point to the right array specifications. While this is
3718 filled in during matching, this information is difficult to save and load
3719 in a module, so we take care of it here.
3721 The idea here is that the original array reference comes from the
3722 base symbol. We traverse the list of reference structures, setting
3723 the stored reference to references. Component references can
3724 provide an additional array specification. */
3727 find_array_spec (gfc_expr
*e
)
3731 gfc_symbol
*derived
;
3734 as
= e
->symtree
->n
.sym
->as
;
3737 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
3742 gfc_internal_error ("find_array_spec(): Missing spec");
3749 if (derived
== NULL
)
3750 derived
= e
->symtree
->n
.sym
->ts
.derived
;
3752 c
= derived
->components
;
3754 for (; c
; c
= c
->next
)
3755 if (c
== ref
->u
.c
.component
)
3757 /* Track the sequence of component references. */
3758 if (c
->ts
.type
== BT_DERIVED
)
3759 derived
= c
->ts
.derived
;
3764 gfc_internal_error ("find_array_spec(): Component not found");
3766 if (c
->attr
.dimension
)
3769 gfc_internal_error ("find_array_spec(): unused as(1)");
3780 gfc_internal_error ("find_array_spec(): unused as(2)");
3784 /* Resolve an array reference. */
3787 resolve_array_ref (gfc_array_ref
*ar
)
3789 int i
, check_scalar
;
3792 for (i
= 0; i
< ar
->dimen
; i
++)
3794 check_scalar
= ar
->dimen_type
[i
] == DIMEN_RANGE
;
3796 if (gfc_resolve_index (ar
->start
[i
], check_scalar
) == FAILURE
)
3798 if (gfc_resolve_index (ar
->end
[i
], check_scalar
) == FAILURE
)
3800 if (gfc_resolve_index (ar
->stride
[i
], check_scalar
) == FAILURE
)
3805 if (ar
->dimen_type
[i
] == DIMEN_UNKNOWN
)
3809 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3813 ar
->dimen_type
[i
] = DIMEN_VECTOR
;
3814 if (e
->expr_type
== EXPR_VARIABLE
3815 && e
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
)
3816 ar
->start
[i
] = gfc_get_parentheses (e
);
3820 gfc_error ("Array index at %L is an array of rank %d",
3821 &ar
->c_where
[i
], e
->rank
);
3826 /* If the reference type is unknown, figure out what kind it is. */
3828 if (ar
->type
== AR_UNKNOWN
)
3830 ar
->type
= AR_ELEMENT
;
3831 for (i
= 0; i
< ar
->dimen
; i
++)
3832 if (ar
->dimen_type
[i
] == DIMEN_RANGE
3833 || ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3835 ar
->type
= AR_SECTION
;
3840 if (!ar
->as
->cray_pointee
&& compare_spec_to_ref (ar
) == FAILURE
)
3848 resolve_substring (gfc_ref
*ref
)
3850 if (ref
->u
.ss
.start
!= NULL
)
3852 if (gfc_resolve_expr (ref
->u
.ss
.start
) == FAILURE
)
3855 if (ref
->u
.ss
.start
->ts
.type
!= BT_INTEGER
)
3857 gfc_error ("Substring start index at %L must be of type INTEGER",
3858 &ref
->u
.ss
.start
->where
);
3862 if (ref
->u
.ss
.start
->rank
!= 0)
3864 gfc_error ("Substring start index at %L must be scalar",
3865 &ref
->u
.ss
.start
->where
);
3869 if (compare_bound_int (ref
->u
.ss
.start
, 1) == CMP_LT
3870 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3871 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3873 gfc_error ("Substring start index at %L is less than one",
3874 &ref
->u
.ss
.start
->where
);
3879 if (ref
->u
.ss
.end
!= NULL
)
3881 if (gfc_resolve_expr (ref
->u
.ss
.end
) == FAILURE
)
3884 if (ref
->u
.ss
.end
->ts
.type
!= BT_INTEGER
)
3886 gfc_error ("Substring end index at %L must be of type INTEGER",
3887 &ref
->u
.ss
.end
->where
);
3891 if (ref
->u
.ss
.end
->rank
!= 0)
3893 gfc_error ("Substring end index at %L must be scalar",
3894 &ref
->u
.ss
.end
->where
);
3898 if (ref
->u
.ss
.length
!= NULL
3899 && compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.length
->length
) == CMP_GT
3900 && (compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_EQ
3901 || compare_bound (ref
->u
.ss
.end
, ref
->u
.ss
.start
) == CMP_GT
))
3903 gfc_error ("Substring end index at %L exceeds the string length",
3904 &ref
->u
.ss
.start
->where
);
3913 /* This function supplies missing substring charlens. */
3916 gfc_resolve_substring_charlen (gfc_expr
*e
)
3919 gfc_expr
*start
, *end
;
3921 for (char_ref
= e
->ref
; char_ref
; char_ref
= char_ref
->next
)
3922 if (char_ref
->type
== REF_SUBSTRING
)
3928 gcc_assert (char_ref
->next
== NULL
);
3932 if (e
->ts
.cl
->length
)
3933 gfc_free_expr (e
->ts
.cl
->length
);
3934 else if (e
->expr_type
== EXPR_VARIABLE
3935 && e
->symtree
->n
.sym
->attr
.dummy
)
3939 e
->ts
.type
= BT_CHARACTER
;
3940 e
->ts
.kind
= gfc_default_character_kind
;
3944 e
->ts
.cl
= gfc_get_charlen ();
3945 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
3946 gfc_current_ns
->cl_list
= e
->ts
.cl
;
3949 if (char_ref
->u
.ss
.start
)
3950 start
= gfc_copy_expr (char_ref
->u
.ss
.start
);
3952 start
= gfc_int_expr (1);
3954 if (char_ref
->u
.ss
.end
)
3955 end
= gfc_copy_expr (char_ref
->u
.ss
.end
);
3956 else if (e
->expr_type
== EXPR_VARIABLE
)
3957 end
= gfc_copy_expr (e
->symtree
->n
.sym
->ts
.cl
->length
);
3964 /* Length = (end - start +1). */
3965 e
->ts
.cl
->length
= gfc_subtract (end
, start
);
3966 e
->ts
.cl
->length
= gfc_add (e
->ts
.cl
->length
, gfc_int_expr (1));
3968 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
3969 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
3971 /* Make sure that the length is simplified. */
3972 gfc_simplify_expr (e
->ts
.cl
->length
, 1);
3973 gfc_resolve_expr (e
->ts
.cl
->length
);
3977 /* Resolve subtype references. */
3980 resolve_ref (gfc_expr
*expr
)
3982 int current_part_dimension
, n_components
, seen_part_dimension
;
3985 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3986 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.as
== NULL
)
3988 find_array_spec (expr
);
3992 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
3996 if (resolve_array_ref (&ref
->u
.ar
) == FAILURE
)
4004 resolve_substring (ref
);
4008 /* Check constraints on part references. */
4010 current_part_dimension
= 0;
4011 seen_part_dimension
= 0;
4014 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4019 switch (ref
->u
.ar
.type
)
4023 current_part_dimension
= 1;
4027 current_part_dimension
= 0;
4031 gfc_internal_error ("resolve_ref(): Bad array reference");
4037 if (current_part_dimension
|| seen_part_dimension
)
4039 if (ref
->u
.c
.component
->attr
.pointer
)
4041 gfc_error ("Component to the right of a part reference "
4042 "with nonzero rank must not have the POINTER "
4043 "attribute at %L", &expr
->where
);
4046 else if (ref
->u
.c
.component
->attr
.allocatable
)
4048 gfc_error ("Component to the right of a part reference "
4049 "with nonzero rank must not have the ALLOCATABLE "
4050 "attribute at %L", &expr
->where
);
4062 if (((ref
->type
== REF_COMPONENT
&& n_components
> 1)
4063 || ref
->next
== NULL
)
4064 && current_part_dimension
4065 && seen_part_dimension
)
4067 gfc_error ("Two or more part references with nonzero rank must "
4068 "not be specified at %L", &expr
->where
);
4072 if (ref
->type
== REF_COMPONENT
)
4074 if (current_part_dimension
)
4075 seen_part_dimension
= 1;
4077 /* reset to make sure */
4078 current_part_dimension
= 0;
4086 /* Given an expression, determine its shape. This is easier than it sounds.
4087 Leaves the shape array NULL if it is not possible to determine the shape. */
4090 expression_shape (gfc_expr
*e
)
4092 mpz_t array
[GFC_MAX_DIMENSIONS
];
4095 if (e
->rank
== 0 || e
->shape
!= NULL
)
4098 for (i
= 0; i
< e
->rank
; i
++)
4099 if (gfc_array_dimen_size (e
, i
, &array
[i
]) == FAILURE
)
4102 e
->shape
= gfc_get_shape (e
->rank
);
4104 memcpy (e
->shape
, array
, e
->rank
* sizeof (mpz_t
));
4109 for (i
--; i
>= 0; i
--)
4110 mpz_clear (array
[i
]);
4114 /* Given a variable expression node, compute the rank of the expression by
4115 examining the base symbol and any reference structures it may have. */
4118 expression_rank (gfc_expr
*e
)
4123 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
4124 could lead to serious confusion... */
4125 gcc_assert (e
->expr_type
!= EXPR_COMPCALL
);
4129 if (e
->expr_type
== EXPR_ARRAY
)
4131 /* Constructors can have a rank different from one via RESHAPE(). */
4133 if (e
->symtree
== NULL
)
4139 e
->rank
= (e
->symtree
->n
.sym
->as
== NULL
)
4140 ? 0 : e
->symtree
->n
.sym
->as
->rank
;
4146 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
4148 if (ref
->type
!= REF_ARRAY
)
4151 if (ref
->u
.ar
.type
== AR_FULL
)
4153 rank
= ref
->u
.ar
.as
->rank
;
4157 if (ref
->u
.ar
.type
== AR_SECTION
)
4159 /* Figure out the rank of the section. */
4161 gfc_internal_error ("expression_rank(): Two array specs");
4163 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
4164 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
4165 || ref
->u
.ar
.dimen_type
[i
] == DIMEN_VECTOR
)
4175 expression_shape (e
);
4179 /* Resolve a variable expression. */
4182 resolve_variable (gfc_expr
*e
)
4189 if (e
->symtree
== NULL
)
4192 if (e
->ref
&& resolve_ref (e
) == FAILURE
)
4195 sym
= e
->symtree
->n
.sym
;
4196 if (sym
->attr
.flavor
== FL_PROCEDURE
&& !sym
->attr
.function
)
4198 e
->ts
.type
= BT_PROCEDURE
;
4199 goto resolve_procedure
;
4202 if (sym
->ts
.type
!= BT_UNKNOWN
)
4203 gfc_variable_attr (e
, &e
->ts
);
4206 /* Must be a simple variable reference. */
4207 if (gfc_set_default_type (sym
, 1, sym
->ns
) == FAILURE
)
4212 if (check_assumed_size_reference (sym
, e
))
4215 /* Deal with forward references to entries during resolve_code, to
4216 satisfy, at least partially, 12.5.2.5. */
4217 if (gfc_current_ns
->entries
4218 && current_entry_id
== sym
->entry_id
4221 && cs_base
->current
->op
!= EXEC_ENTRY
)
4223 gfc_entry_list
*entry
;
4224 gfc_formal_arglist
*formal
;
4228 /* If the symbol is a dummy... */
4229 if (sym
->attr
.dummy
&& sym
->ns
== gfc_current_ns
)
4231 entry
= gfc_current_ns
->entries
;
4234 /* ...test if the symbol is a parameter of previous entries. */
4235 for (; entry
&& entry
->id
<= current_entry_id
; entry
= entry
->next
)
4236 for (formal
= entry
->sym
->formal
; formal
; formal
= formal
->next
)
4238 if (formal
->sym
&& sym
->name
== formal
->sym
->name
)
4242 /* If it has not been seen as a dummy, this is an error. */
4245 if (specification_expr
)
4246 gfc_error ("Variable '%s', used in a specification expression"
4247 ", is referenced at %L before the ENTRY statement "
4248 "in which it is a parameter",
4249 sym
->name
, &cs_base
->current
->loc
);
4251 gfc_error ("Variable '%s' is used at %L before the ENTRY "
4252 "statement in which it is a parameter",
4253 sym
->name
, &cs_base
->current
->loc
);
4258 /* Now do the same check on the specification expressions. */
4259 specification_expr
= 1;
4260 if (sym
->ts
.type
== BT_CHARACTER
4261 && gfc_resolve_expr (sym
->ts
.cl
->length
) == FAILURE
)
4265 for (n
= 0; n
< sym
->as
->rank
; n
++)
4267 specification_expr
= 1;
4268 if (gfc_resolve_expr (sym
->as
->lower
[n
]) == FAILURE
)
4270 specification_expr
= 1;
4271 if (gfc_resolve_expr (sym
->as
->upper
[n
]) == FAILURE
)
4274 specification_expr
= 0;
4277 /* Update the symbol's entry level. */
4278 sym
->entry_id
= current_entry_id
+ 1;
4282 if (t
== SUCCESS
&& resolve_procedure_expression (e
) == FAILURE
)
4289 /* Checks to see that the correct symbol has been host associated.
4290 The only situation where this arises is that in which a twice
4291 contained function is parsed after the host association is made.
4292 Therefore, on detecting this, the line is rematched, having got
4293 rid of the existing references and actual_arg_list. */
4295 check_host_association (gfc_expr
*e
)
4297 gfc_symbol
*sym
, *old_sym
;
4301 bool retval
= e
->expr_type
== EXPR_FUNCTION
;
4303 /* If the expression is the result of substitution in
4304 interface.c(gfc_extend_expr) because there is no way in
4305 which the host association can be wrong. */
4306 if (e
->symtree
== NULL
4307 || e
->symtree
->n
.sym
== NULL
4308 || e
->user_operator
)
4311 old_sym
= e
->symtree
->n
.sym
;
4313 if (gfc_current_ns
->parent
4314 && old_sym
->ns
!= gfc_current_ns
)
4316 gfc_find_symbol (old_sym
->name
, gfc_current_ns
, 1, &sym
);
4317 if (sym
&& old_sym
!= sym
4318 && sym
->ts
.type
== old_sym
->ts
.type
4319 && sym
->attr
.flavor
== FL_PROCEDURE
4320 && sym
->attr
.contained
)
4322 temp_locus
= gfc_current_locus
;
4323 gfc_current_locus
= e
->where
;
4325 gfc_buffer_error (1);
4327 gfc_free_ref_list (e
->ref
);
4332 gfc_free_actual_arglist (e
->value
.function
.actual
);
4333 e
->value
.function
.actual
= NULL
;
4336 if (e
->shape
!= NULL
)
4338 for (n
= 0; n
< e
->rank
; n
++)
4339 mpz_clear (e
->shape
[n
]);
4341 gfc_free (e
->shape
);
4344 /* TODO - Replace this gfc_match_rvalue with a straight replacement of
4345 actual arglists for function to function substitutions and with a
4346 conversion of the reference list to an actual arglist in the case of
4347 a variable to function replacement. This should be quite easy since
4348 only integers and vectors can be involved. */
4349 gfc_match_rvalue (&expr
);
4351 gfc_buffer_error (0);
4353 gcc_assert (expr
&& sym
== expr
->symtree
->n
.sym
);
4359 gfc_current_locus
= temp_locus
;
4362 /* This might have changed! */
4363 return e
->expr_type
== EXPR_FUNCTION
;
4368 gfc_resolve_character_operator (gfc_expr
*e
)
4370 gfc_expr
*op1
= e
->value
.op
.op1
;
4371 gfc_expr
*op2
= e
->value
.op
.op2
;
4372 gfc_expr
*e1
= NULL
;
4373 gfc_expr
*e2
= NULL
;
4375 gcc_assert (e
->value
.op
.op
== INTRINSIC_CONCAT
);
4377 if (op1
->ts
.cl
&& op1
->ts
.cl
->length
)
4378 e1
= gfc_copy_expr (op1
->ts
.cl
->length
);
4379 else if (op1
->expr_type
== EXPR_CONSTANT
)
4380 e1
= gfc_int_expr (op1
->value
.character
.length
);
4382 if (op2
->ts
.cl
&& op2
->ts
.cl
->length
)
4383 e2
= gfc_copy_expr (op2
->ts
.cl
->length
);
4384 else if (op2
->expr_type
== EXPR_CONSTANT
)
4385 e2
= gfc_int_expr (op2
->value
.character
.length
);
4387 e
->ts
.cl
= gfc_get_charlen ();
4388 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4389 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4394 e
->ts
.cl
->length
= gfc_add (e1
, e2
);
4395 e
->ts
.cl
->length
->ts
.type
= BT_INTEGER
;
4396 e
->ts
.cl
->length
->ts
.kind
= gfc_charlen_int_kind
;;
4397 gfc_simplify_expr (e
->ts
.cl
->length
, 0);
4398 gfc_resolve_expr (e
->ts
.cl
->length
);
4404 /* Ensure that an character expression has a charlen and, if possible, a
4405 length expression. */
4408 fixup_charlen (gfc_expr
*e
)
4410 /* The cases fall through so that changes in expression type and the need
4411 for multiple fixes are picked up. In all circumstances, a charlen should
4412 be available for the middle end to hang a backend_decl on. */
4413 switch (e
->expr_type
)
4416 gfc_resolve_character_operator (e
);
4419 if (e
->expr_type
== EXPR_ARRAY
)
4420 gfc_resolve_character_array_constructor (e
);
4422 case EXPR_SUBSTRING
:
4423 if (!e
->ts
.cl
&& e
->ref
)
4424 gfc_resolve_substring_charlen (e
);
4429 e
->ts
.cl
= gfc_get_charlen ();
4430 e
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
4431 gfc_current_ns
->cl_list
= e
->ts
.cl
;
4439 /* Update an actual argument to include the passed-object for type-bound
4440 procedures at the right position. */
4442 static gfc_actual_arglist
*
4443 update_arglist_pass (gfc_actual_arglist
* lst
, gfc_expr
* po
, unsigned argpos
)
4445 gcc_assert (argpos
> 0);
4449 gfc_actual_arglist
* result
;
4451 result
= gfc_get_actual_arglist ();
4459 gcc_assert (argpos
> 1);
4461 lst
->next
= update_arglist_pass (lst
->next
, po
, argpos
- 1);
4466 /* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
4469 extract_compcall_passed_object (gfc_expr
* e
)
4473 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4475 po
= gfc_get_expr ();
4476 po
->expr_type
= EXPR_VARIABLE
;
4477 po
->symtree
= e
->symtree
;
4478 po
->ref
= gfc_copy_ref (e
->ref
);
4480 if (gfc_resolve_expr (po
) == FAILURE
)
4487 /* Update the arglist of an EXPR_COMPCALL expression to include the
4491 update_compcall_arglist (gfc_expr
* e
)
4494 gfc_typebound_proc
* tbp
;
4496 tbp
= e
->value
.compcall
.tbp
;
4501 po
= extract_compcall_passed_object (e
);
4507 gfc_error ("Passed-object at %L must be scalar", &e
->where
);
4517 gcc_assert (tbp
->pass_arg_num
> 0);
4518 e
->value
.compcall
.actual
= update_arglist_pass (e
->value
.compcall
.actual
, po
,
4525 /* Resolve a call to a type-bound procedure, either function or subroutine,
4526 statically from the data in an EXPR_COMPCALL expression. The adapted
4527 arglist and the target-procedure symtree are returned. */
4530 resolve_typebound_static (gfc_expr
* e
, gfc_symtree
** target
,
4531 gfc_actual_arglist
** actual
)
4533 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4534 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
4536 /* Update the actual arglist for PASS. */
4537 if (update_compcall_arglist (e
) == FAILURE
)
4540 *actual
= e
->value
.compcall
.actual
;
4541 *target
= e
->value
.compcall
.tbp
->u
.specific
;
4543 gfc_free_ref_list (e
->ref
);
4545 e
->value
.compcall
.actual
= NULL
;
4551 /* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
4552 which of the specific bindings (if any) matches the arglist and transform
4553 the expression into a call of that binding. */
4556 resolve_typebound_generic_call (gfc_expr
* e
)
4558 gfc_typebound_proc
* genproc
;
4559 const char* genname
;
4561 gcc_assert (e
->expr_type
== EXPR_COMPCALL
);
4562 genname
= e
->value
.compcall
.name
;
4563 genproc
= e
->value
.compcall
.tbp
;
4565 if (!genproc
->is_generic
)
4568 /* Try the bindings on this type and in the inheritance hierarchy. */
4569 for (; genproc
; genproc
= genproc
->overridden
)
4573 gcc_assert (genproc
->is_generic
);
4574 for (g
= genproc
->u
.generic
; g
; g
= g
->next
)
4577 gfc_actual_arglist
* args
;
4580 gcc_assert (g
->specific
);
4582 if (g
->specific
->error
)
4585 target
= g
->specific
->u
.specific
->n
.sym
;
4587 /* Get the right arglist by handling PASS/NOPASS. */
4588 args
= gfc_copy_actual_arglist (e
->value
.compcall
.actual
);
4589 if (!g
->specific
->nopass
)
4592 po
= extract_compcall_passed_object (e
);
4596 gcc_assert (g
->specific
->pass_arg_num
> 0);
4597 gcc_assert (!g
->specific
->error
);
4598 args
= update_arglist_pass (args
, po
, g
->specific
->pass_arg_num
);
4600 resolve_actual_arglist (args
, target
->attr
.proc
,
4601 is_external_proc (target
) && !target
->formal
);
4603 /* Check if this arglist matches the formal. */
4604 matches
= gfc_arglist_matches_symbol (&args
, target
);
4606 /* Clean up and break out of the loop if we've found it. */
4607 gfc_free_actual_arglist (args
);
4610 e
->value
.compcall
.tbp
= g
->specific
;
4616 /* Nothing matching found! */
4617 gfc_error ("Found no matching specific binding for the call to the GENERIC"
4618 " '%s' at %L", genname
, &e
->where
);
4626 /* Resolve a call to a type-bound subroutine. */
4629 resolve_typebound_call (gfc_code
* c
)
4631 gfc_actual_arglist
* newactual
;
4632 gfc_symtree
* target
;
4634 /* Check that's really a SUBROUTINE. */
4635 if (!c
->expr
->value
.compcall
.tbp
->subroutine
)
4637 gfc_error ("'%s' at %L should be a SUBROUTINE",
4638 c
->expr
->value
.compcall
.name
, &c
->loc
);
4642 if (resolve_typebound_generic_call (c
->expr
) == FAILURE
)
4645 /* Transform into an ordinary EXEC_CALL for now. */
4647 if (resolve_typebound_static (c
->expr
, &target
, &newactual
) == FAILURE
)
4650 c
->ext
.actual
= newactual
;
4651 c
->symtree
= target
;
4654 gcc_assert (!c
->expr
->ref
&& !c
->expr
->value
.compcall
.actual
);
4655 gfc_free_expr (c
->expr
);
4658 return resolve_call (c
);
4662 /* Resolve a component-call expression. */
4665 resolve_compcall (gfc_expr
* e
)
4667 gfc_actual_arglist
* newactual
;
4668 gfc_symtree
* target
;
4670 /* Check that's really a FUNCTION. */
4671 if (!e
->value
.compcall
.tbp
->function
)
4673 gfc_error ("'%s' at %L should be a FUNCTION",
4674 e
->value
.compcall
.name
, &e
->where
);
4678 if (resolve_typebound_generic_call (e
) == FAILURE
)
4680 gcc_assert (!e
->value
.compcall
.tbp
->is_generic
);
4682 /* Take the rank from the function's symbol. */
4683 if (e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
)
4684 e
->rank
= e
->value
.compcall
.tbp
->u
.specific
->n
.sym
->as
->rank
;
4686 /* For now, we simply transform it into an EXPR_FUNCTION call with the same
4687 arglist to the TBP's binding target. */
4689 if (resolve_typebound_static (e
, &target
, &newactual
) == FAILURE
)
4692 e
->value
.function
.actual
= newactual
;
4693 e
->value
.function
.name
= e
->value
.compcall
.name
;
4694 e
->value
.function
.isym
= NULL
;
4695 e
->value
.function
.esym
= NULL
;
4696 e
->symtree
= target
;
4697 e
->ts
= target
->n
.sym
->ts
;
4698 e
->expr_type
= EXPR_FUNCTION
;
4700 return gfc_resolve_expr (e
);
4704 /* Resolve an expression. That is, make sure that types of operands agree
4705 with their operators, intrinsic operators are converted to function calls
4706 for overloaded types and unresolved function references are resolved. */
4709 gfc_resolve_expr (gfc_expr
*e
)
4716 switch (e
->expr_type
)
4719 t
= resolve_operator (e
);
4725 if (check_host_association (e
))
4726 t
= resolve_function (e
);
4729 t
= resolve_variable (e
);
4731 expression_rank (e
);
4734 if (e
->ts
.type
== BT_CHARACTER
&& e
->ts
.cl
== NULL
&& e
->ref
4735 && e
->ref
->type
!= REF_SUBSTRING
)
4736 gfc_resolve_substring_charlen (e
);
4741 t
= resolve_compcall (e
);
4744 case EXPR_SUBSTRING
:
4745 t
= resolve_ref (e
);
4755 if (resolve_ref (e
) == FAILURE
)
4758 t
= gfc_resolve_array_constructor (e
);
4759 /* Also try to expand a constructor. */
4762 expression_rank (e
);
4763 gfc_expand_constructor (e
);
4766 /* This provides the opportunity for the length of constructors with
4767 character valued function elements to propagate the string length
4768 to the expression. */
4769 if (t
== SUCCESS
&& e
->ts
.type
== BT_CHARACTER
)
4770 t
= gfc_resolve_character_array_constructor (e
);
4774 case EXPR_STRUCTURE
:
4775 t
= resolve_ref (e
);
4779 t
= resolve_structure_cons (e
);
4783 t
= gfc_simplify_expr (e
, 0);
4787 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
4790 if (e
->ts
.type
== BT_CHARACTER
&& t
== SUCCESS
&& !e
->ts
.cl
)
4797 /* Resolve an expression from an iterator. They must be scalar and have
4798 INTEGER or (optionally) REAL type. */
4801 gfc_resolve_iterator_expr (gfc_expr
*expr
, bool real_ok
,
4802 const char *name_msgid
)
4804 if (gfc_resolve_expr (expr
) == FAILURE
)
4807 if (expr
->rank
!= 0)
4809 gfc_error ("%s at %L must be a scalar", _(name_msgid
), &expr
->where
);
4813 if (expr
->ts
.type
!= BT_INTEGER
)
4815 if (expr
->ts
.type
== BT_REAL
)
4818 return gfc_notify_std (GFC_STD_F95_DEL
,
4819 "Deleted feature: %s at %L must be integer",
4820 _(name_msgid
), &expr
->where
);
4823 gfc_error ("%s at %L must be INTEGER", _(name_msgid
),
4830 gfc_error ("%s at %L must be INTEGER", _(name_msgid
), &expr
->where
);
4838 /* Resolve the expressions in an iterator structure. If REAL_OK is
4839 false allow only INTEGER type iterators, otherwise allow REAL types. */
4842 gfc_resolve_iterator (gfc_iterator
*iter
, bool real_ok
)
4844 if (gfc_resolve_iterator_expr (iter
->var
, real_ok
, "Loop variable")
4848 if (gfc_pure (NULL
) && gfc_impure_variable (iter
->var
->symtree
->n
.sym
))
4850 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
4855 if (gfc_resolve_iterator_expr (iter
->start
, real_ok
,
4856 "Start expression in DO loop") == FAILURE
)
4859 if (gfc_resolve_iterator_expr (iter
->end
, real_ok
,
4860 "End expression in DO loop") == FAILURE
)
4863 if (gfc_resolve_iterator_expr (iter
->step
, real_ok
,
4864 "Step expression in DO loop") == FAILURE
)
4867 if (iter
->step
->expr_type
== EXPR_CONSTANT
)
4869 if ((iter
->step
->ts
.type
== BT_INTEGER
4870 && mpz_cmp_ui (iter
->step
->value
.integer
, 0) == 0)
4871 || (iter
->step
->ts
.type
== BT_REAL
4872 && mpfr_sgn (iter
->step
->value
.real
) == 0))
4874 gfc_error ("Step expression in DO loop at %L cannot be zero",
4875 &iter
->step
->where
);
4880 /* Convert start, end, and step to the same type as var. */
4881 if (iter
->start
->ts
.kind
!= iter
->var
->ts
.kind
4882 || iter
->start
->ts
.type
!= iter
->var
->ts
.type
)
4883 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4885 if (iter
->end
->ts
.kind
!= iter
->var
->ts
.kind
4886 || iter
->end
->ts
.type
!= iter
->var
->ts
.type
)
4887 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4889 if (iter
->step
->ts
.kind
!= iter
->var
->ts
.kind
4890 || iter
->step
->ts
.type
!= iter
->var
->ts
.type
)
4891 gfc_convert_type (iter
->step
, &iter
->var
->ts
, 2);
4897 /* Traversal function for find_forall_index. f == 2 signals that
4898 that variable itself is not to be checked - only the references. */
4901 forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
4903 if (expr
->expr_type
!= EXPR_VARIABLE
)
4906 /* A scalar assignment */
4907 if (!expr
->ref
|| *f
== 1)
4909 if (expr
->symtree
->n
.sym
== sym
)
4921 /* Check whether the FORALL index appears in the expression or not.
4922 Returns SUCCESS if SYM is found in EXPR. */
4925 find_forall_index (gfc_expr
*expr
, gfc_symbol
*sym
, int f
)
4927 if (gfc_traverse_expr (expr
, sym
, forall_index
, f
))
4934 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
4935 to be a scalar INTEGER variable. The subscripts and stride are scalar
4936 INTEGERs, and if stride is a constant it must be nonzero.
4937 Furthermore "A subscript or stride in a forall-triplet-spec shall
4938 not contain a reference to any index-name in the
4939 forall-triplet-spec-list in which it appears." (7.5.4.1) */
4942 resolve_forall_iterators (gfc_forall_iterator
*it
)
4944 gfc_forall_iterator
*iter
, *iter2
;
4946 for (iter
= it
; iter
; iter
= iter
->next
)
4948 if (gfc_resolve_expr (iter
->var
) == SUCCESS
4949 && (iter
->var
->ts
.type
!= BT_INTEGER
|| iter
->var
->rank
!= 0))
4950 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
4953 if (gfc_resolve_expr (iter
->start
) == SUCCESS
4954 && (iter
->start
->ts
.type
!= BT_INTEGER
|| iter
->start
->rank
!= 0))
4955 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
4956 &iter
->start
->where
);
4957 if (iter
->var
->ts
.kind
!= iter
->start
->ts
.kind
)
4958 gfc_convert_type (iter
->start
, &iter
->var
->ts
, 2);
4960 if (gfc_resolve_expr (iter
->end
) == SUCCESS
4961 && (iter
->end
->ts
.type
!= BT_INTEGER
|| iter
->end
->rank
!= 0))
4962 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
4964 if (iter
->var
->ts
.kind
!= iter
->end
->ts
.kind
)
4965 gfc_convert_type (iter
->end
, &iter
->var
->ts
, 2);
4967 if (gfc_resolve_expr (iter
->stride
) == SUCCESS
)
4969 if (iter
->stride
->ts
.type
!= BT_INTEGER
|| iter
->stride
->rank
!= 0)
4970 gfc_error ("FORALL stride expression at %L must be a scalar %s",
4971 &iter
->stride
->where
, "INTEGER");
4973 if (iter
->stride
->expr_type
== EXPR_CONSTANT
4974 && mpz_cmp_ui(iter
->stride
->value
.integer
, 0) == 0)
4975 gfc_error ("FORALL stride expression at %L cannot be zero",
4976 &iter
->stride
->where
);
4978 if (iter
->var
->ts
.kind
!= iter
->stride
->ts
.kind
)
4979 gfc_convert_type (iter
->stride
, &iter
->var
->ts
, 2);
4982 for (iter
= it
; iter
; iter
= iter
->next
)
4983 for (iter2
= iter
; iter2
; iter2
= iter2
->next
)
4985 if (find_forall_index (iter2
->start
,
4986 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4987 || find_forall_index (iter2
->end
,
4988 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
4989 || find_forall_index (iter2
->stride
,
4990 iter
->var
->symtree
->n
.sym
, 0) == SUCCESS
)
4991 gfc_error ("FORALL index '%s' may not appear in triplet "
4992 "specification at %L", iter
->var
->symtree
->name
,
4993 &iter2
->start
->where
);
4998 /* Given a pointer to a symbol that is a derived type, see if it's
4999 inaccessible, i.e. if it's defined in another module and the components are
5000 PRIVATE. The search is recursive if necessary. Returns zero if no
5001 inaccessible components are found, nonzero otherwise. */
5004 derived_inaccessible (gfc_symbol
*sym
)
5008 if (sym
->attr
.use_assoc
&& sym
->attr
.private_comp
)
5011 for (c
= sym
->components
; c
; c
= c
->next
)
5013 if (c
->ts
.type
== BT_DERIVED
&& derived_inaccessible (c
->ts
.derived
))
5021 /* Resolve the argument of a deallocate expression. The expression must be
5022 a pointer or a full array. */
5025 resolve_deallocate_expr (gfc_expr
*e
)
5027 symbol_attribute attr
;
5028 int allocatable
, pointer
, check_intent_in
;
5031 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5032 check_intent_in
= 1;
5034 if (gfc_resolve_expr (e
) == FAILURE
)
5037 if (e
->expr_type
!= EXPR_VARIABLE
)
5040 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
5041 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
5042 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
5045 check_intent_in
= 0;
5050 if (ref
->u
.ar
.type
!= AR_FULL
)
5055 allocatable
= (ref
->u
.c
.component
->as
!= NULL
5056 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
5057 pointer
= ref
->u
.c
.component
->attr
.pointer
;
5066 attr
= gfc_expr_attr (e
);
5068 if (allocatable
== 0 && attr
.pointer
== 0)
5071 gfc_error ("Expression in DEALLOCATE statement at %L must be "
5072 "ALLOCATABLE or a POINTER", &e
->where
);
5076 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
5078 gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
5079 e
->symtree
->n
.sym
->name
, &e
->where
);
5087 /* Returns true if the expression e contains a reference to the symbol sym. */
5089 sym_in_expr (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
5091 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
->n
.sym
== sym
)
5098 gfc_find_sym_in_expr (gfc_symbol
*sym
, gfc_expr
*e
)
5100 return gfc_traverse_expr (e
, sym
, sym_in_expr
, 0);
5104 /* Given the expression node e for an allocatable/pointer of derived type to be
5105 allocated, get the expression node to be initialized afterwards (needed for
5106 derived types with default initializers, and derived types with allocatable
5107 components that need nullification.) */
5110 expr_to_initialize (gfc_expr
*e
)
5116 result
= gfc_copy_expr (e
);
5118 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
5119 for (ref
= result
->ref
; ref
; ref
= ref
->next
)
5120 if (ref
->type
== REF_ARRAY
&& ref
->next
== NULL
)
5122 ref
->u
.ar
.type
= AR_FULL
;
5124 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
5125 ref
->u
.ar
.start
[i
] = ref
->u
.ar
.end
[i
] = ref
->u
.ar
.stride
[i
] = NULL
;
5127 result
->rank
= ref
->u
.ar
.dimen
;
5135 /* Resolve the expression in an ALLOCATE statement, doing the additional
5136 checks to see whether the expression is OK or not. The expression must
5137 have a trailing array reference that gives the size of the array. */
5140 resolve_allocate_expr (gfc_expr
*e
, gfc_code
*code
)
5142 int i
, pointer
, allocatable
, dimension
, check_intent_in
;
5143 symbol_attribute attr
;
5144 gfc_ref
*ref
, *ref2
;
5151 /* Check INTENT(IN), unless the object is a sub-component of a pointer. */
5152 check_intent_in
= 1;
5154 if (gfc_resolve_expr (e
) == FAILURE
)
5157 if (code
->expr
&& code
->expr
->expr_type
== EXPR_VARIABLE
)
5158 sym
= code
->expr
->symtree
->n
.sym
;
5162 /* Make sure the expression is allocatable or a pointer. If it is
5163 pointer, the next-to-last reference must be a pointer. */
5167 if (e
->expr_type
!= EXPR_VARIABLE
)
5170 attr
= gfc_expr_attr (e
);
5171 pointer
= attr
.pointer
;
5172 dimension
= attr
.dimension
;
5176 allocatable
= e
->symtree
->n
.sym
->attr
.allocatable
;
5177 pointer
= e
->symtree
->n
.sym
->attr
.pointer
;
5178 dimension
= e
->symtree
->n
.sym
->attr
.dimension
;
5180 if (sym
== e
->symtree
->n
.sym
&& sym
->ts
.type
!= BT_DERIVED
)
5182 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
5183 "not be allocated in the same statement at %L",
5184 sym
->name
, &e
->where
);
5188 for (ref
= e
->ref
; ref
; ref2
= ref
, ref
= ref
->next
)
5191 check_intent_in
= 0;
5196 if (ref
->next
!= NULL
)
5201 allocatable
= (ref
->u
.c
.component
->as
!= NULL
5202 && ref
->u
.c
.component
->as
->type
== AS_DEFERRED
);
5204 pointer
= ref
->u
.c
.component
->attr
.pointer
;
5205 dimension
= ref
->u
.c
.component
->attr
.dimension
;
5216 if (allocatable
== 0 && pointer
== 0)
5218 gfc_error ("Expression in ALLOCATE statement at %L must be "
5219 "ALLOCATABLE or a POINTER", &e
->where
);
5224 && e
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
5226 gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
5227 e
->symtree
->n
.sym
->name
, &e
->where
);
5231 /* Add default initializer for those derived types that need them. */
5232 if (e
->ts
.type
== BT_DERIVED
&& (init_e
= gfc_default_initializer (&e
->ts
)))
5234 init_st
= gfc_get_code ();
5235 init_st
->loc
= code
->loc
;
5236 init_st
->op
= EXEC_INIT_ASSIGN
;
5237 init_st
->expr
= expr_to_initialize (e
);
5238 init_st
->expr2
= init_e
;
5239 init_st
->next
= code
->next
;
5240 code
->next
= init_st
;
5243 if (pointer
&& dimension
== 0)
5246 /* Make sure the next-to-last reference node is an array specification. */
5248 if (ref2
== NULL
|| ref2
->type
!= REF_ARRAY
|| ref2
->u
.ar
.type
== AR_FULL
)
5250 gfc_error ("Array specification required in ALLOCATE statement "
5251 "at %L", &e
->where
);
5255 /* Make sure that the array section reference makes sense in the
5256 context of an ALLOCATE specification. */
5260 for (i
= 0; i
< ar
->dimen
; i
++)
5262 if (ref2
->u
.ar
.type
== AR_ELEMENT
)
5265 switch (ar
->dimen_type
[i
])
5271 if (ar
->start
[i
] != NULL
5272 && ar
->end
[i
] != NULL
5273 && ar
->stride
[i
] == NULL
)
5276 /* Fall Through... */
5280 gfc_error ("Bad array specification in ALLOCATE statement at %L",
5287 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5289 sym
= a
->expr
->symtree
->n
.sym
;
5291 /* TODO - check derived type components. */
5292 if (sym
->ts
.type
== BT_DERIVED
)
5295 if ((ar
->start
[i
] != NULL
5296 && gfc_find_sym_in_expr (sym
, ar
->start
[i
]))
5297 || (ar
->end
[i
] != NULL
5298 && gfc_find_sym_in_expr (sym
, ar
->end
[i
])))
5300 gfc_error ("'%s' must not appear in the array specification at "
5301 "%L in the same ALLOCATE statement where it is "
5302 "itself allocated", sym
->name
, &ar
->where
);
5312 resolve_allocate_deallocate (gfc_code
*code
, const char *fcn
)
5314 gfc_symbol
*s
= NULL
;
5318 s
= code
->expr
->symtree
->n
.sym
;
5322 if (s
->attr
.intent
== INTENT_IN
)
5323 gfc_error ("STAT variable '%s' of %s statement at %C cannot "
5324 "be INTENT(IN)", s
->name
, fcn
);
5326 if (gfc_pure (NULL
) && gfc_impure_variable (s
))
5327 gfc_error ("Illegal STAT variable in %s statement at %C "
5328 "for a PURE procedure", fcn
);
5331 if (s
&& code
->expr
->ts
.type
!= BT_INTEGER
)
5332 gfc_error ("STAT tag in %s statement at %L must be "
5333 "of type INTEGER", fcn
, &code
->expr
->where
);
5335 if (strcmp (fcn
, "ALLOCATE") == 0)
5337 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5338 resolve_allocate_expr (a
->expr
, code
);
5342 for (a
= code
->ext
.alloc_list
; a
; a
= a
->next
)
5343 resolve_deallocate_expr (a
->expr
);
5347 /************ SELECT CASE resolution subroutines ************/
5349 /* Callback function for our mergesort variant. Determines interval
5350 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
5351 op1 > op2. Assumes we're not dealing with the default case.
5352 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
5353 There are nine situations to check. */
5356 compare_cases (const gfc_case
*op1
, const gfc_case
*op2
)
5360 if (op1
->low
== NULL
) /* op1 = (:L) */
5362 /* op2 = (:N), so overlap. */
5364 /* op2 = (M:) or (M:N), L < M */
5365 if (op2
->low
!= NULL
5366 && gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5369 else if (op1
->high
== NULL
) /* op1 = (K:) */
5371 /* op2 = (M:), so overlap. */
5373 /* op2 = (:N) or (M:N), K > N */
5374 if (op2
->high
!= NULL
5375 && gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5378 else /* op1 = (K:L) */
5380 if (op2
->low
== NULL
) /* op2 = (:N), K > N */
5381 retval
= (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5383 else if (op2
->high
== NULL
) /* op2 = (M:), L < M */
5384 retval
= (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5386 else /* op2 = (M:N) */
5390 if (gfc_compare_expr (op1
->high
, op2
->low
, INTRINSIC_LT
) < 0)
5393 else if (gfc_compare_expr (op1
->low
, op2
->high
, INTRINSIC_GT
) > 0)
5402 /* Merge-sort a double linked case list, detecting overlap in the
5403 process. LIST is the head of the double linked case list before it
5404 is sorted. Returns the head of the sorted list if we don't see any
5405 overlap, or NULL otherwise. */
5408 check_case_overlap (gfc_case
*list
)
5410 gfc_case
*p
, *q
, *e
, *tail
;
5411 int insize
, nmerges
, psize
, qsize
, cmp
, overlap_seen
;
5413 /* If the passed list was empty, return immediately. */
5420 /* Loop unconditionally. The only exit from this loop is a return
5421 statement, when we've finished sorting the case list. */
5428 /* Count the number of merges we do in this pass. */
5431 /* Loop while there exists a merge to be done. */
5436 /* Count this merge. */
5439 /* Cut the list in two pieces by stepping INSIZE places
5440 forward in the list, starting from P. */
5443 for (i
= 0; i
< insize
; i
++)
5452 /* Now we have two lists. Merge them! */
5453 while (psize
> 0 || (qsize
> 0 && q
!= NULL
))
5455 /* See from which the next case to merge comes from. */
5458 /* P is empty so the next case must come from Q. */
5463 else if (qsize
== 0 || q
== NULL
)
5472 cmp
= compare_cases (p
, q
);
5475 /* The whole case range for P is less than the
5483 /* The whole case range for Q is greater than
5484 the case range for P. */
5491 /* The cases overlap, or they are the same
5492 element in the list. Either way, we must
5493 issue an error and get the next case from P. */
5494 /* FIXME: Sort P and Q by line number. */
5495 gfc_error ("CASE label at %L overlaps with CASE "
5496 "label at %L", &p
->where
, &q
->where
);
5504 /* Add the next element to the merged list. */
5513 /* P has now stepped INSIZE places along, and so has Q. So
5514 they're the same. */
5519 /* If we have done only one merge or none at all, we've
5520 finished sorting the cases. */
5529 /* Otherwise repeat, merging lists twice the size. */
5535 /* Check to see if an expression is suitable for use in a CASE statement.
5536 Makes sure that all case expressions are scalar constants of the same
5537 type. Return FAILURE if anything is wrong. */
5540 validate_case_label_expr (gfc_expr
*e
, gfc_expr
*case_expr
)
5542 if (e
== NULL
) return SUCCESS
;
5544 if (e
->ts
.type
!= case_expr
->ts
.type
)
5546 gfc_error ("Expression in CASE statement at %L must be of type %s",
5547 &e
->where
, gfc_basic_typename (case_expr
->ts
.type
));
5551 /* C805 (R808) For a given case-construct, each case-value shall be of
5552 the same type as case-expr. For character type, length differences
5553 are allowed, but the kind type parameters shall be the same. */
5555 if (case_expr
->ts
.type
== BT_CHARACTER
&& e
->ts
.kind
!= case_expr
->ts
.kind
)
5557 gfc_error ("Expression in CASE statement at %L must be of kind %d",
5558 &e
->where
, case_expr
->ts
.kind
);
5562 /* Convert the case value kind to that of case expression kind, if needed.
5563 FIXME: Should a warning be issued? */
5564 if (e
->ts
.kind
!= case_expr
->ts
.kind
)
5565 gfc_convert_type_warn (e
, &case_expr
->ts
, 2, 0);
5569 gfc_error ("Expression in CASE statement at %L must be scalar",
5578 /* Given a completely parsed select statement, we:
5580 - Validate all expressions and code within the SELECT.
5581 - Make sure that the selection expression is not of the wrong type.
5582 - Make sure that no case ranges overlap.
5583 - Eliminate unreachable cases and unreachable code resulting from
5584 removing case labels.
5586 The standard does allow unreachable cases, e.g. CASE (5:3). But
5587 they are a hassle for code generation, and to prevent that, we just
5588 cut them out here. This is not necessary for overlapping cases
5589 because they are illegal and we never even try to generate code.
5591 We have the additional caveat that a SELECT construct could have
5592 been a computed GOTO in the source code. Fortunately we can fairly
5593 easily work around that here: The case_expr for a "real" SELECT CASE
5594 is in code->expr1, but for a computed GOTO it is in code->expr2. All
5595 we have to do is make sure that the case_expr is a scalar integer
5599 resolve_select (gfc_code
*code
)
5602 gfc_expr
*case_expr
;
5603 gfc_case
*cp
, *default_case
, *tail
, *head
;
5604 int seen_unreachable
;
5610 if (code
->expr
== NULL
)
5612 /* This was actually a computed GOTO statement. */
5613 case_expr
= code
->expr2
;
5614 if (case_expr
->ts
.type
!= BT_INTEGER
|| case_expr
->rank
!= 0)
5615 gfc_error ("Selection expression in computed GOTO statement "
5616 "at %L must be a scalar integer expression",
5619 /* Further checking is not necessary because this SELECT was built
5620 by the compiler, so it should always be OK. Just move the
5621 case_expr from expr2 to expr so that we can handle computed
5622 GOTOs as normal SELECTs from here on. */
5623 code
->expr
= code
->expr2
;
5628 case_expr
= code
->expr
;
5630 type
= case_expr
->ts
.type
;
5631 if (type
!= BT_LOGICAL
&& type
!= BT_INTEGER
&& type
!= BT_CHARACTER
)
5633 gfc_error ("Argument of SELECT statement at %L cannot be %s",
5634 &case_expr
->where
, gfc_typename (&case_expr
->ts
));
5636 /* Punt. Going on here just produce more garbage error messages. */
5640 if (case_expr
->rank
!= 0)
5642 gfc_error ("Argument of SELECT statement at %L must be a scalar "
5643 "expression", &case_expr
->where
);
5649 /* PR 19168 has a long discussion concerning a mismatch of the kinds
5650 of the SELECT CASE expression and its CASE values. Walk the lists
5651 of case values, and if we find a mismatch, promote case_expr to
5652 the appropriate kind. */
5654 if (type
== BT_LOGICAL
|| type
== BT_INTEGER
)
5656 for (body
= code
->block
; body
; body
= body
->block
)
5658 /* Walk the case label list. */
5659 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5661 /* Intercept the DEFAULT case. It does not have a kind. */
5662 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5665 /* Unreachable case ranges are discarded, so ignore. */
5666 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5667 && cp
->low
!= cp
->high
5668 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5671 /* FIXME: Should a warning be issued? */
5673 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->low
))
5674 gfc_convert_type_warn (case_expr
, &cp
->low
->ts
, 2, 0);
5676 if (cp
->high
!= NULL
5677 && case_expr
->ts
.kind
!= gfc_kind_max(case_expr
, cp
->high
))
5678 gfc_convert_type_warn (case_expr
, &cp
->high
->ts
, 2, 0);
5683 /* Assume there is no DEFAULT case. */
5684 default_case
= NULL
;
5689 for (body
= code
->block
; body
; body
= body
->block
)
5691 /* Assume the CASE list is OK, and all CASE labels can be matched. */
5693 seen_unreachable
= 0;
5695 /* Walk the case label list, making sure that all case labels
5697 for (cp
= body
->ext
.case_list
; cp
; cp
= cp
->next
)
5699 /* Count the number of cases in the whole construct. */
5702 /* Intercept the DEFAULT case. */
5703 if (cp
->low
== NULL
&& cp
->high
== NULL
)
5705 if (default_case
!= NULL
)
5707 gfc_error ("The DEFAULT CASE at %L cannot be followed "
5708 "by a second DEFAULT CASE at %L",
5709 &default_case
->where
, &cp
->where
);
5720 /* Deal with single value cases and case ranges. Errors are
5721 issued from the validation function. */
5722 if(validate_case_label_expr (cp
->low
, case_expr
) != SUCCESS
5723 || validate_case_label_expr (cp
->high
, case_expr
) != SUCCESS
)
5729 if (type
== BT_LOGICAL
5730 && ((cp
->low
== NULL
|| cp
->high
== NULL
)
5731 || cp
->low
!= cp
->high
))
5733 gfc_error ("Logical range in CASE statement at %L is not "
5734 "allowed", &cp
->low
->where
);
5739 if (type
== BT_LOGICAL
&& cp
->low
->expr_type
== EXPR_CONSTANT
)
5742 value
= cp
->low
->value
.logical
== 0 ? 2 : 1;
5743 if (value
& seen_logical
)
5745 gfc_error ("constant logical value in CASE statement "
5746 "is repeated at %L",
5751 seen_logical
|= value
;
5754 if (cp
->low
!= NULL
&& cp
->high
!= NULL
5755 && cp
->low
!= cp
->high
5756 && gfc_compare_expr (cp
->low
, cp
->high
, INTRINSIC_GT
) > 0)
5758 if (gfc_option
.warn_surprising
)
5759 gfc_warning ("Range specification at %L can never "
5760 "be matched", &cp
->where
);
5762 cp
->unreachable
= 1;
5763 seen_unreachable
= 1;
5767 /* If the case range can be matched, it can also overlap with
5768 other cases. To make sure it does not, we put it in a
5769 double linked list here. We sort that with a merge sort
5770 later on to detect any overlapping cases. */
5774 head
->right
= head
->left
= NULL
;
5779 tail
->right
->left
= tail
;
5786 /* It there was a failure in the previous case label, give up
5787 for this case label list. Continue with the next block. */
5791 /* See if any case labels that are unreachable have been seen.
5792 If so, we eliminate them. This is a bit of a kludge because
5793 the case lists for a single case statement (label) is a
5794 single forward linked lists. */
5795 if (seen_unreachable
)
5797 /* Advance until the first case in the list is reachable. */
5798 while (body
->ext
.case_list
!= NULL
5799 && body
->ext
.case_list
->unreachable
)
5801 gfc_case
*n
= body
->ext
.case_list
;
5802 body
->ext
.case_list
= body
->ext
.case_list
->next
;
5804 gfc_free_case_list (n
);
5807 /* Strip all other unreachable cases. */
5808 if (body
->ext
.case_list
)
5810 for (cp
= body
->ext
.case_list
; cp
->next
; cp
= cp
->next
)
5812 if (cp
->next
->unreachable
)
5814 gfc_case
*n
= cp
->next
;
5815 cp
->next
= cp
->next
->next
;
5817 gfc_free_case_list (n
);
5824 /* See if there were overlapping cases. If the check returns NULL,
5825 there was overlap. In that case we don't do anything. If head
5826 is non-NULL, we prepend the DEFAULT case. The sorted list can
5827 then used during code generation for SELECT CASE constructs with
5828 a case expression of a CHARACTER type. */
5831 head
= check_case_overlap (head
);
5833 /* Prepend the default_case if it is there. */
5834 if (head
!= NULL
&& default_case
)
5836 default_case
->left
= NULL
;
5837 default_case
->right
= head
;
5838 head
->left
= default_case
;
5842 /* Eliminate dead blocks that may be the result if we've seen
5843 unreachable case labels for a block. */
5844 for (body
= code
; body
&& body
->block
; body
= body
->block
)
5846 if (body
->block
->ext
.case_list
== NULL
)
5848 /* Cut the unreachable block from the code chain. */
5849 gfc_code
*c
= body
->block
;
5850 body
->block
= c
->block
;
5852 /* Kill the dead block, but not the blocks below it. */
5854 gfc_free_statements (c
);
5858 /* More than two cases is legal but insane for logical selects.
5859 Issue a warning for it. */
5860 if (gfc_option
.warn_surprising
&& type
== BT_LOGICAL
5862 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
5867 /* Resolve a transfer statement. This is making sure that:
5868 -- a derived type being transferred has only non-pointer components
5869 -- a derived type being transferred doesn't have private components, unless
5870 it's being transferred from the module where the type was defined
5871 -- we're not trying to transfer a whole assumed size array. */
5874 resolve_transfer (gfc_code
*code
)
5883 if (exp
->expr_type
!= EXPR_VARIABLE
&& exp
->expr_type
!= EXPR_FUNCTION
)
5886 sym
= exp
->symtree
->n
.sym
;
5889 /* Go to actual component transferred. */
5890 for (ref
= code
->expr
->ref
; ref
; ref
= ref
->next
)
5891 if (ref
->type
== REF_COMPONENT
)
5892 ts
= &ref
->u
.c
.component
->ts
;
5894 if (ts
->type
== BT_DERIVED
)
5896 /* Check that transferred derived type doesn't contain POINTER
5898 if (ts
->derived
->attr
.pointer_comp
)
5900 gfc_error ("Data transfer element at %L cannot have "
5901 "POINTER components", &code
->loc
);
5905 if (ts
->derived
->attr
.alloc_comp
)
5907 gfc_error ("Data transfer element at %L cannot have "
5908 "ALLOCATABLE components", &code
->loc
);
5912 if (derived_inaccessible (ts
->derived
))
5914 gfc_error ("Data transfer element at %L cannot have "
5915 "PRIVATE components",&code
->loc
);
5920 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SIZE
5921 && exp
->ref
->type
== REF_ARRAY
&& exp
->ref
->u
.ar
.type
== AR_FULL
)
5923 gfc_error ("Data transfer element at %L cannot be a full reference to "
5924 "an assumed-size array", &code
->loc
);
5930 /*********** Toplevel code resolution subroutines ***********/
5932 /* Find the set of labels that are reachable from this block. We also
5933 record the last statement in each block so that we don't have to do
5934 a linear search to find the END DO statements of the blocks. */
5937 reachable_labels (gfc_code
*block
)
5944 cs_base
->reachable_labels
= bitmap_obstack_alloc (&labels_obstack
);
5946 /* Collect labels in this block. */
5947 for (c
= block
; c
; c
= c
->next
)
5950 bitmap_set_bit (cs_base
->reachable_labels
, c
->here
->value
);
5952 if (!c
->next
&& cs_base
->prev
)
5953 cs_base
->prev
->tail
= c
;
5956 /* Merge with labels from parent block. */
5959 gcc_assert (cs_base
->prev
->reachable_labels
);
5960 bitmap_ior_into (cs_base
->reachable_labels
,
5961 cs_base
->prev
->reachable_labels
);
5965 /* Given a branch to a label and a namespace, if the branch is conforming.
5966 The code node describes where the branch is located. */
5969 resolve_branch (gfc_st_label
*label
, gfc_code
*code
)
5976 /* Step one: is this a valid branching target? */
5978 if (label
->defined
== ST_LABEL_UNKNOWN
)
5980 gfc_error ("Label %d referenced at %L is never defined", label
->value
,
5985 if (label
->defined
!= ST_LABEL_TARGET
)
5987 gfc_error ("Statement at %L is not a valid branch target statement "
5988 "for the branch statement at %L", &label
->where
, &code
->loc
);
5992 /* Step two: make sure this branch is not a branch to itself ;-) */
5994 if (code
->here
== label
)
5996 gfc_warning ("Branch at %L may result in an infinite loop", &code
->loc
);
6000 /* Step three: See if the label is in the same block as the
6001 branching statement. The hard work has been done by setting up
6002 the bitmap reachable_labels. */
6004 if (!bitmap_bit_p (cs_base
->reachable_labels
, label
->value
))
6006 /* The label is not in an enclosing block, so illegal. This was
6007 allowed in Fortran 66, so we allow it as extension. No
6008 further checks are necessary in this case. */
6009 gfc_notify_std (GFC_STD_LEGACY
, "Label at %L is not in the same block "
6010 "as the GOTO statement at %L", &label
->where
,
6015 /* Step four: Make sure that the branching target is legal if
6016 the statement is an END {SELECT,IF}. */
6018 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
6019 if (stack
->current
->next
&& stack
->current
->next
->here
== label
)
6022 if (stack
&& stack
->current
->next
->op
== EXEC_NOP
)
6024 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps to "
6025 "END of construct at %L", &code
->loc
,
6026 &stack
->current
->next
->loc
);
6027 return; /* We know this is not an END DO. */
6030 /* Step five: Make sure that we're not jumping to the end of a DO
6031 loop from within the loop. */
6033 for (stack
= cs_base
; stack
; stack
= stack
->prev
)
6034 if ((stack
->current
->op
== EXEC_DO
6035 || stack
->current
->op
== EXEC_DO_WHILE
)
6036 && stack
->tail
->here
== label
&& stack
->tail
->op
== EXEC_NOP
)
6038 gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: GOTO at %L jumps "
6039 "to END of construct at %L", &code
->loc
,
6047 /* Check whether EXPR1 has the same shape as EXPR2. */
6050 resolve_where_shape (gfc_expr
*expr1
, gfc_expr
*expr2
)
6052 mpz_t shape
[GFC_MAX_DIMENSIONS
];
6053 mpz_t shape2
[GFC_MAX_DIMENSIONS
];
6054 gfc_try result
= FAILURE
;
6057 /* Compare the rank. */
6058 if (expr1
->rank
!= expr2
->rank
)
6061 /* Compare the size of each dimension. */
6062 for (i
=0; i
<expr1
->rank
; i
++)
6064 if (gfc_array_dimen_size (expr1
, i
, &shape
[i
]) == FAILURE
)
6067 if (gfc_array_dimen_size (expr2
, i
, &shape2
[i
]) == FAILURE
)
6070 if (mpz_cmp (shape
[i
], shape2
[i
]))
6074 /* When either of the two expression is an assumed size array, we
6075 ignore the comparison of dimension sizes. */
6080 for (i
--; i
>= 0; i
--)
6082 mpz_clear (shape
[i
]);
6083 mpz_clear (shape2
[i
]);
6089 /* Check whether a WHERE assignment target or a WHERE mask expression
6090 has the same shape as the outmost WHERE mask expression. */
6093 resolve_where (gfc_code
*code
, gfc_expr
*mask
)
6099 cblock
= code
->block
;
6101 /* Store the first WHERE mask-expr of the WHERE statement or construct.
6102 In case of nested WHERE, only the outmost one is stored. */
6103 if (mask
== NULL
) /* outmost WHERE */
6105 else /* inner WHERE */
6112 /* Check if the mask-expr has a consistent shape with the
6113 outmost WHERE mask-expr. */
6114 if (resolve_where_shape (cblock
->expr
, e
) == FAILURE
)
6115 gfc_error ("WHERE mask at %L has inconsistent shape",
6116 &cblock
->expr
->where
);
6119 /* the assignment statement of a WHERE statement, or the first
6120 statement in where-body-construct of a WHERE construct */
6121 cnext
= cblock
->next
;
6126 /* WHERE assignment statement */
6129 /* Check shape consistent for WHERE assignment target. */
6130 if (e
&& resolve_where_shape (cnext
->expr
, e
) == FAILURE
)
6131 gfc_error ("WHERE assignment target at %L has "
6132 "inconsistent shape", &cnext
->expr
->where
);
6136 case EXEC_ASSIGN_CALL
:
6137 resolve_call (cnext
);
6138 if (!cnext
->resolved_sym
->attr
.elemental
)
6139 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6140 &cnext
->ext
.actual
->expr
->where
);
6143 /* WHERE or WHERE construct is part of a where-body-construct */
6145 resolve_where (cnext
, e
);
6149 gfc_error ("Unsupported statement inside WHERE at %L",
6152 /* the next statement within the same where-body-construct */
6153 cnext
= cnext
->next
;
6155 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6156 cblock
= cblock
->block
;
6161 /* Resolve assignment in FORALL construct.
6162 NVAR is the number of FORALL index variables, and VAR_EXPR records the
6163 FORALL index variables. */
6166 gfc_resolve_assign_in_forall (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
6170 for (n
= 0; n
< nvar
; n
++)
6172 gfc_symbol
*forall_index
;
6174 forall_index
= var_expr
[n
]->symtree
->n
.sym
;
6176 /* Check whether the assignment target is one of the FORALL index
6178 if ((code
->expr
->expr_type
== EXPR_VARIABLE
)
6179 && (code
->expr
->symtree
->n
.sym
== forall_index
))
6180 gfc_error ("Assignment to a FORALL index variable at %L",
6181 &code
->expr
->where
);
6184 /* If one of the FORALL index variables doesn't appear in the
6185 assignment variable, then there could be a many-to-one
6186 assignment. Emit a warning rather than an error because the
6187 mask could be resolving this problem. */
6188 if (find_forall_index (code
->expr
, forall_index
, 0) == FAILURE
)
6189 gfc_warning ("The FORALL with index '%s' is not used on the "
6190 "left side of the assignment at %L and so might "
6191 "cause multiple assignment to this object",
6192 var_expr
[n
]->symtree
->name
, &code
->expr
->where
);
6198 /* Resolve WHERE statement in FORALL construct. */
6201 gfc_resolve_where_code_in_forall (gfc_code
*code
, int nvar
,
6202 gfc_expr
**var_expr
)
6207 cblock
= code
->block
;
6210 /* the assignment statement of a WHERE statement, or the first
6211 statement in where-body-construct of a WHERE construct */
6212 cnext
= cblock
->next
;
6217 /* WHERE assignment statement */
6219 gfc_resolve_assign_in_forall (cnext
, nvar
, var_expr
);
6222 /* WHERE operator assignment statement */
6223 case EXEC_ASSIGN_CALL
:
6224 resolve_call (cnext
);
6225 if (!cnext
->resolved_sym
->attr
.elemental
)
6226 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
6227 &cnext
->ext
.actual
->expr
->where
);
6230 /* WHERE or WHERE construct is part of a where-body-construct */
6232 gfc_resolve_where_code_in_forall (cnext
, nvar
, var_expr
);
6236 gfc_error ("Unsupported statement inside WHERE at %L",
6239 /* the next statement within the same where-body-construct */
6240 cnext
= cnext
->next
;
6242 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
6243 cblock
= cblock
->block
;
6248 /* Traverse the FORALL body to check whether the following errors exist:
6249 1. For assignment, check if a many-to-one assignment happens.
6250 2. For WHERE statement, check the WHERE body to see if there is any
6251 many-to-one assignment. */
6254 gfc_resolve_forall_body (gfc_code
*code
, int nvar
, gfc_expr
**var_expr
)
6258 c
= code
->block
->next
;
6264 case EXEC_POINTER_ASSIGN
:
6265 gfc_resolve_assign_in_forall (c
, nvar
, var_expr
);
6268 case EXEC_ASSIGN_CALL
:
6272 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
6273 there is no need to handle it here. */
6277 gfc_resolve_where_code_in_forall(c
, nvar
, var_expr
);
6282 /* The next statement in the FORALL body. */
6288 /* Counts the number of iterators needed inside a forall construct, including
6289 nested forall constructs. This is used to allocate the needed memory
6290 in gfc_resolve_forall. */
6293 gfc_count_forall_iterators (gfc_code
*code
)
6295 int max_iters
, sub_iters
, current_iters
;
6296 gfc_forall_iterator
*fa
;
6298 gcc_assert(code
->op
== EXEC_FORALL
);
6302 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
6305 code
= code
->block
->next
;
6309 if (code
->op
== EXEC_FORALL
)
6311 sub_iters
= gfc_count_forall_iterators (code
);
6312 if (sub_iters
> max_iters
)
6313 max_iters
= sub_iters
;
6318 return current_iters
+ max_iters
;
6322 /* Given a FORALL construct, first resolve the FORALL iterator, then call
6323 gfc_resolve_forall_body to resolve the FORALL body. */
6326 gfc_resolve_forall (gfc_code
*code
, gfc_namespace
*ns
, int forall_save
)
6328 static gfc_expr
**var_expr
;
6329 static int total_var
= 0;
6330 static int nvar
= 0;
6332 gfc_forall_iterator
*fa
;
6337 /* Start to resolve a FORALL construct */
6338 if (forall_save
== 0)
6340 /* Count the total number of FORALL index in the nested FORALL
6341 construct in order to allocate the VAR_EXPR with proper size. */
6342 total_var
= gfc_count_forall_iterators (code
);
6344 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
6345 var_expr
= (gfc_expr
**) gfc_getmem (total_var
* sizeof (gfc_expr
*));
6348 /* The information about FORALL iterator, including FORALL index start, end
6349 and stride. The FORALL index can not appear in start, end or stride. */
6350 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
6352 /* Check if any outer FORALL index name is the same as the current
6354 for (i
= 0; i
< nvar
; i
++)
6356 if (fa
->var
->symtree
->n
.sym
== var_expr
[i
]->symtree
->n
.sym
)
6358 gfc_error ("An outer FORALL construct already has an index "
6359 "with this name %L", &fa
->var
->where
);
6363 /* Record the current FORALL index. */
6364 var_expr
[nvar
] = gfc_copy_expr (fa
->var
);
6368 /* No memory leak. */
6369 gcc_assert (nvar
<= total_var
);
6372 /* Resolve the FORALL body. */
6373 gfc_resolve_forall_body (code
, nvar
, var_expr
);
6375 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
6376 gfc_resolve_blocks (code
->block
, ns
);
6380 /* Free only the VAR_EXPRs allocated in this frame. */
6381 for (i
= nvar
; i
< tmp
; i
++)
6382 gfc_free_expr (var_expr
[i
]);
6386 /* We are in the outermost FORALL construct. */
6387 gcc_assert (forall_save
== 0);
6389 /* VAR_EXPR is not needed any more. */
6390 gfc_free (var_expr
);
6396 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
6399 static void resolve_code (gfc_code
*, gfc_namespace
*);
6402 gfc_resolve_blocks (gfc_code
*b
, gfc_namespace
*ns
)
6406 for (; b
; b
= b
->block
)
6408 t
= gfc_resolve_expr (b
->expr
);
6409 if (gfc_resolve_expr (b
->expr2
) == FAILURE
)
6415 if (t
== SUCCESS
&& b
->expr
!= NULL
6416 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
!= 0))
6417 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6424 && (b
->expr
->ts
.type
!= BT_LOGICAL
|| b
->expr
->rank
== 0))
6425 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
6430 resolve_branch (b
->label
, b
);
6443 case EXEC_OMP_ATOMIC
:
6444 case EXEC_OMP_CRITICAL
:
6446 case EXEC_OMP_MASTER
:
6447 case EXEC_OMP_ORDERED
:
6448 case EXEC_OMP_PARALLEL
:
6449 case EXEC_OMP_PARALLEL_DO
:
6450 case EXEC_OMP_PARALLEL_SECTIONS
:
6451 case EXEC_OMP_PARALLEL_WORKSHARE
:
6452 case EXEC_OMP_SECTIONS
:
6453 case EXEC_OMP_SINGLE
:
6455 case EXEC_OMP_TASKWAIT
:
6456 case EXEC_OMP_WORKSHARE
:
6460 gfc_internal_error ("resolve_block(): Bad block type");
6463 resolve_code (b
->next
, ns
);
6468 /* Does everything to resolve an ordinary assignment. Returns true
6469 if this is an interface assignment. */
6471 resolve_ordinary_assign (gfc_code
*code
, gfc_namespace
*ns
)
6481 if (gfc_extend_assign (code
, ns
) == SUCCESS
)
6483 lhs
= code
->ext
.actual
->expr
;
6484 rhs
= code
->ext
.actual
->next
->expr
;
6485 if (gfc_pure (NULL
) && !gfc_pure (code
->symtree
->n
.sym
))
6487 gfc_error ("Subroutine '%s' called instead of assignment at "
6488 "%L must be PURE", code
->symtree
->n
.sym
->name
,
6493 /* Make a temporary rhs when there is a default initializer
6494 and rhs is the same symbol as the lhs. */
6495 if (rhs
->expr_type
== EXPR_VARIABLE
6496 && rhs
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
6497 && has_default_initializer (rhs
->symtree
->n
.sym
->ts
.derived
)
6498 && (lhs
->symtree
->n
.sym
== rhs
->symtree
->n
.sym
))
6499 code
->ext
.actual
->next
->expr
= gfc_get_parentheses (rhs
);
6508 && gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ literal at %L outside "
6509 "a DATA statement and outside INT/REAL/DBLE/CMPLX",
6510 &code
->loc
) == FAILURE
)
6513 /* Handle the case of a BOZ literal on the RHS. */
6514 if (rhs
->is_boz
&& lhs
->ts
.type
!= BT_INTEGER
)
6517 if (gfc_option
.warn_surprising
)
6518 gfc_warning ("BOZ literal at %L is bitwise transferred "
6519 "non-integer symbol '%s'", &code
->loc
,
6520 lhs
->symtree
->n
.sym
->name
);
6522 if (!gfc_convert_boz (rhs
, &lhs
->ts
))
6524 if ((rc
= gfc_range_check (rhs
)) != ARITH_OK
)
6526 if (rc
== ARITH_UNDERFLOW
)
6527 gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
6528 ". This check can be disabled with the option "
6529 "-fno-range-check", &rhs
->where
);
6530 else if (rc
== ARITH_OVERFLOW
)
6531 gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
6532 ". This check can be disabled with the option "
6533 "-fno-range-check", &rhs
->where
);
6534 else if (rc
== ARITH_NAN
)
6535 gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
6536 ". This check can be disabled with the option "
6537 "-fno-range-check", &rhs
->where
);
6543 if (lhs
->ts
.type
== BT_CHARACTER
6544 && gfc_option
.warn_character_truncation
)
6546 if (lhs
->ts
.cl
!= NULL
6547 && lhs
->ts
.cl
->length
!= NULL
6548 && lhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6549 llen
= mpz_get_si (lhs
->ts
.cl
->length
->value
.integer
);
6551 if (rhs
->expr_type
== EXPR_CONSTANT
)
6552 rlen
= rhs
->value
.character
.length
;
6554 else if (rhs
->ts
.cl
!= NULL
6555 && rhs
->ts
.cl
->length
!= NULL
6556 && rhs
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
6557 rlen
= mpz_get_si (rhs
->ts
.cl
->length
->value
.integer
);
6559 if (rlen
&& llen
&& rlen
> llen
)
6560 gfc_warning_now ("CHARACTER expression will be truncated "
6561 "in assignment (%d/%d) at %L",
6562 llen
, rlen
, &code
->loc
);
6565 /* Ensure that a vector index expression for the lvalue is evaluated
6566 to a temporary if the lvalue symbol is referenced in it. */
6569 for (ref
= lhs
->ref
; ref
; ref
= ref
->next
)
6570 if (ref
->type
== REF_ARRAY
)
6572 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
6573 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
6574 && gfc_find_sym_in_expr (lhs
->symtree
->n
.sym
,
6575 ref
->u
.ar
.start
[n
]))
6577 = gfc_get_parentheses (ref
->u
.ar
.start
[n
]);
6581 if (gfc_pure (NULL
))
6583 if (gfc_impure_variable (lhs
->symtree
->n
.sym
))
6585 gfc_error ("Cannot assign to variable '%s' in PURE "
6587 lhs
->symtree
->n
.sym
->name
,
6592 if (lhs
->ts
.type
== BT_DERIVED
6593 && lhs
->expr_type
== EXPR_VARIABLE
6594 && lhs
->ts
.derived
->attr
.pointer_comp
6595 && gfc_impure_variable (rhs
->symtree
->n
.sym
))
6597 gfc_error ("The impure variable at %L is assigned to "
6598 "a derived type variable with a POINTER "
6599 "component in a PURE procedure (12.6)",
6605 gfc_check_assign (lhs
, rhs
, 1);
6609 /* Given a block of code, recursively resolve everything pointed to by this
6613 resolve_code (gfc_code
*code
, gfc_namespace
*ns
)
6615 int omp_workshare_save
;
6620 frame
.prev
= cs_base
;
6624 reachable_labels (code
);
6626 for (; code
; code
= code
->next
)
6628 frame
.current
= code
;
6629 forall_save
= forall_flag
;
6631 if (code
->op
== EXEC_FORALL
)
6634 gfc_resolve_forall (code
, ns
, forall_save
);
6637 else if (code
->block
)
6639 omp_workshare_save
= -1;
6642 case EXEC_OMP_PARALLEL_WORKSHARE
:
6643 omp_workshare_save
= omp_workshare_flag
;
6644 omp_workshare_flag
= 1;
6645 gfc_resolve_omp_parallel_blocks (code
, ns
);
6647 case EXEC_OMP_PARALLEL
:
6648 case EXEC_OMP_PARALLEL_DO
:
6649 case EXEC_OMP_PARALLEL_SECTIONS
:
6651 omp_workshare_save
= omp_workshare_flag
;
6652 omp_workshare_flag
= 0;
6653 gfc_resolve_omp_parallel_blocks (code
, ns
);
6656 gfc_resolve_omp_do_blocks (code
, ns
);
6658 case EXEC_OMP_WORKSHARE
:
6659 omp_workshare_save
= omp_workshare_flag
;
6660 omp_workshare_flag
= 1;
6663 gfc_resolve_blocks (code
->block
, ns
);
6667 if (omp_workshare_save
!= -1)
6668 omp_workshare_flag
= omp_workshare_save
;
6672 if (code
->op
!= EXEC_COMPCALL
)
6673 t
= gfc_resolve_expr (code
->expr
);
6674 forall_flag
= forall_save
;
6676 if (gfc_resolve_expr (code
->expr2
) == FAILURE
)
6691 /* Keep track of which entry we are up to. */
6692 current_entry_id
= code
->ext
.entry
->id
;
6696 resolve_where (code
, NULL
);
6700 if (code
->expr
!= NULL
)
6702 if (code
->expr
->ts
.type
!= BT_INTEGER
)
6703 gfc_error ("ASSIGNED GOTO statement at %L requires an "
6704 "INTEGER variable", &code
->expr
->where
);
6705 else if (code
->expr
->symtree
->n
.sym
->attr
.assign
!= 1)
6706 gfc_error ("Variable '%s' has not been assigned a target "
6707 "label at %L", code
->expr
->symtree
->n
.sym
->name
,
6708 &code
->expr
->where
);
6711 resolve_branch (code
->label
, code
);
6715 if (code
->expr
!= NULL
6716 && (code
->expr
->ts
.type
!= BT_INTEGER
|| code
->expr
->rank
))
6717 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
6718 "INTEGER return specifier", &code
->expr
->where
);
6721 case EXEC_INIT_ASSIGN
:
6728 if (resolve_ordinary_assign (code
, ns
))
6733 case EXEC_LABEL_ASSIGN
:
6734 if (code
->label
->defined
== ST_LABEL_UNKNOWN
)
6735 gfc_error ("Label %d referenced at %L is never defined",
6736 code
->label
->value
, &code
->label
->where
);
6738 && (code
->expr
->expr_type
!= EXPR_VARIABLE
6739 || code
->expr
->symtree
->n
.sym
->ts
.type
!= BT_INTEGER
6740 || code
->expr
->symtree
->n
.sym
->ts
.kind
6741 != gfc_default_integer_kind
6742 || code
->expr
->symtree
->n
.sym
->as
!= NULL
))
6743 gfc_error ("ASSIGN statement at %L requires a scalar "
6744 "default INTEGER variable", &code
->expr
->where
);
6747 case EXEC_POINTER_ASSIGN
:
6751 gfc_check_pointer_assign (code
->expr
, code
->expr2
);
6754 case EXEC_ARITHMETIC_IF
:
6756 && code
->expr
->ts
.type
!= BT_INTEGER
6757 && code
->expr
->ts
.type
!= BT_REAL
)
6758 gfc_error ("Arithmetic IF statement at %L requires a numeric "
6759 "expression", &code
->expr
->where
);
6761 resolve_branch (code
->label
, code
);
6762 resolve_branch (code
->label2
, code
);
6763 resolve_branch (code
->label3
, code
);
6767 if (t
== SUCCESS
&& code
->expr
!= NULL
6768 && (code
->expr
->ts
.type
!= BT_LOGICAL
6769 || code
->expr
->rank
!= 0))
6770 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
6771 &code
->expr
->where
);
6776 resolve_call (code
);
6780 resolve_typebound_call (code
);
6784 /* Select is complicated. Also, a SELECT construct could be
6785 a transformed computed GOTO. */
6786 resolve_select (code
);
6790 if (code
->ext
.iterator
!= NULL
)
6792 gfc_iterator
*iter
= code
->ext
.iterator
;
6793 if (gfc_resolve_iterator (iter
, true) != FAILURE
)
6794 gfc_resolve_do_iterator (code
, iter
->var
->symtree
->n
.sym
);
6799 if (code
->expr
== NULL
)
6800 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
6802 && (code
->expr
->rank
!= 0
6803 || code
->expr
->ts
.type
!= BT_LOGICAL
))
6804 gfc_error ("Exit condition of DO WHILE loop at %L must be "
6805 "a scalar LOGICAL expression", &code
->expr
->where
);
6810 resolve_allocate_deallocate (code
, "ALLOCATE");
6814 case EXEC_DEALLOCATE
:
6816 resolve_allocate_deallocate (code
, "DEALLOCATE");
6821 if (gfc_resolve_open (code
->ext
.open
) == FAILURE
)
6824 resolve_branch (code
->ext
.open
->err
, code
);
6828 if (gfc_resolve_close (code
->ext
.close
) == FAILURE
)
6831 resolve_branch (code
->ext
.close
->err
, code
);
6834 case EXEC_BACKSPACE
:
6838 if (gfc_resolve_filepos (code
->ext
.filepos
) == FAILURE
)
6841 resolve_branch (code
->ext
.filepos
->err
, code
);
6845 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6848 resolve_branch (code
->ext
.inquire
->err
, code
);
6852 gcc_assert (code
->ext
.inquire
!= NULL
);
6853 if (gfc_resolve_inquire (code
->ext
.inquire
) == FAILURE
)
6856 resolve_branch (code
->ext
.inquire
->err
, code
);
6860 if (gfc_resolve_wait (code
->ext
.wait
) == FAILURE
)
6863 resolve_branch (code
->ext
.wait
->err
, code
);
6864 resolve_branch (code
->ext
.wait
->end
, code
);
6865 resolve_branch (code
->ext
.wait
->eor
, code
);
6870 if (gfc_resolve_dt (code
->ext
.dt
) == FAILURE
)
6873 resolve_branch (code
->ext
.dt
->err
, code
);
6874 resolve_branch (code
->ext
.dt
->end
, code
);
6875 resolve_branch (code
->ext
.dt
->eor
, code
);
6879 resolve_transfer (code
);
6883 resolve_forall_iterators (code
->ext
.forall_iterator
);
6885 if (code
->expr
!= NULL
&& code
->expr
->ts
.type
!= BT_LOGICAL
)
6886 gfc_error ("FORALL mask clause at %L requires a LOGICAL "
6887 "expression", &code
->expr
->where
);
6890 case EXEC_OMP_ATOMIC
:
6891 case EXEC_OMP_BARRIER
:
6892 case EXEC_OMP_CRITICAL
:
6893 case EXEC_OMP_FLUSH
:
6895 case EXEC_OMP_MASTER
:
6896 case EXEC_OMP_ORDERED
:
6897 case EXEC_OMP_SECTIONS
:
6898 case EXEC_OMP_SINGLE
:
6899 case EXEC_OMP_TASKWAIT
:
6900 case EXEC_OMP_WORKSHARE
:
6901 gfc_resolve_omp_directive (code
, ns
);
6904 case EXEC_OMP_PARALLEL
:
6905 case EXEC_OMP_PARALLEL_DO
:
6906 case EXEC_OMP_PARALLEL_SECTIONS
:
6907 case EXEC_OMP_PARALLEL_WORKSHARE
:
6909 omp_workshare_save
= omp_workshare_flag
;
6910 omp_workshare_flag
= 0;
6911 gfc_resolve_omp_directive (code
, ns
);
6912 omp_workshare_flag
= omp_workshare_save
;
6916 gfc_internal_error ("resolve_code(): Bad statement code");
6920 cs_base
= frame
.prev
;
6924 /* Resolve initial values and make sure they are compatible with
6928 resolve_values (gfc_symbol
*sym
)
6930 if (sym
->value
== NULL
)
6933 if (gfc_resolve_expr (sym
->value
) == FAILURE
)
6936 gfc_check_assign_symbol (sym
, sym
->value
);
6940 /* Verify the binding labels for common blocks that are BIND(C). The label
6941 for a BIND(C) common block must be identical in all scoping units in which
6942 the common block is declared. Further, the binding label can not collide
6943 with any other global entity in the program. */
6946 resolve_bind_c_comms (gfc_symtree
*comm_block_tree
)
6948 if (comm_block_tree
->n
.common
->is_bind_c
== 1)
6950 gfc_gsymbol
*binding_label_gsym
;
6951 gfc_gsymbol
*comm_name_gsym
;
6953 /* See if a global symbol exists by the common block's name. It may
6954 be NULL if the common block is use-associated. */
6955 comm_name_gsym
= gfc_find_gsymbol (gfc_gsym_root
,
6956 comm_block_tree
->n
.common
->name
);
6957 if (comm_name_gsym
!= NULL
&& comm_name_gsym
->type
!= GSYM_COMMON
)
6958 gfc_error ("Binding label '%s' for common block '%s' at %L collides "
6959 "with the global entity '%s' at %L",
6960 comm_block_tree
->n
.common
->binding_label
,
6961 comm_block_tree
->n
.common
->name
,
6962 &(comm_block_tree
->n
.common
->where
),
6963 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
6964 else if (comm_name_gsym
!= NULL
6965 && strcmp (comm_name_gsym
->name
,
6966 comm_block_tree
->n
.common
->name
) == 0)
6968 /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
6970 if (comm_name_gsym
->binding_label
== NULL
)
6971 /* No binding label for common block stored yet; save this one. */
6972 comm_name_gsym
->binding_label
=
6973 comm_block_tree
->n
.common
->binding_label
;
6975 if (strcmp (comm_name_gsym
->binding_label
,
6976 comm_block_tree
->n
.common
->binding_label
) != 0)
6978 /* Common block names match but binding labels do not. */
6979 gfc_error ("Binding label '%s' for common block '%s' at %L "
6980 "does not match the binding label '%s' for common "
6982 comm_block_tree
->n
.common
->binding_label
,
6983 comm_block_tree
->n
.common
->name
,
6984 &(comm_block_tree
->n
.common
->where
),
6985 comm_name_gsym
->binding_label
,
6986 comm_name_gsym
->name
,
6987 &(comm_name_gsym
->where
));
6992 /* There is no binding label (NAME="") so we have nothing further to
6993 check and nothing to add as a global symbol for the label. */
6994 if (comm_block_tree
->n
.common
->binding_label
[0] == '\0' )
6997 binding_label_gsym
=
6998 gfc_find_gsymbol (gfc_gsym_root
,
6999 comm_block_tree
->n
.common
->binding_label
);
7000 if (binding_label_gsym
== NULL
)
7002 /* Need to make a global symbol for the binding label to prevent
7003 it from colliding with another. */
7004 binding_label_gsym
=
7005 gfc_get_gsymbol (comm_block_tree
->n
.common
->binding_label
);
7006 binding_label_gsym
->sym_name
= comm_block_tree
->n
.common
->name
;
7007 binding_label_gsym
->type
= GSYM_COMMON
;
7011 /* If comm_name_gsym is NULL, the name common block is use
7012 associated and the name could be colliding. */
7013 if (binding_label_gsym
->type
!= GSYM_COMMON
)
7014 gfc_error ("Binding label '%s' for common block '%s' at %L "
7015 "collides with the global entity '%s' at %L",
7016 comm_block_tree
->n
.common
->binding_label
,
7017 comm_block_tree
->n
.common
->name
,
7018 &(comm_block_tree
->n
.common
->where
),
7019 binding_label_gsym
->name
,
7020 &(binding_label_gsym
->where
));
7021 else if (comm_name_gsym
!= NULL
7022 && (strcmp (binding_label_gsym
->name
,
7023 comm_name_gsym
->binding_label
) != 0)
7024 && (strcmp (binding_label_gsym
->sym_name
,
7025 comm_name_gsym
->name
) != 0))
7026 gfc_error ("Binding label '%s' for common block '%s' at %L "
7027 "collides with global entity '%s' at %L",
7028 binding_label_gsym
->name
, binding_label_gsym
->sym_name
,
7029 &(comm_block_tree
->n
.common
->where
),
7030 comm_name_gsym
->name
, &(comm_name_gsym
->where
));
7038 /* Verify any BIND(C) derived types in the namespace so we can report errors
7039 for them once, rather than for each variable declared of that type. */
7042 resolve_bind_c_derived_types (gfc_symbol
*derived_sym
)
7044 if (derived_sym
!= NULL
&& derived_sym
->attr
.flavor
== FL_DERIVED
7045 && derived_sym
->attr
.is_bind_c
== 1)
7046 verify_bind_c_derived_type (derived_sym
);
7052 /* Verify that any binding labels used in a given namespace do not collide
7053 with the names or binding labels of any global symbols. */
7056 gfc_verify_binding_labels (gfc_symbol
*sym
)
7060 if (sym
!= NULL
&& sym
->attr
.is_bind_c
&& sym
->attr
.is_iso_c
== 0
7061 && sym
->attr
.flavor
!= FL_DERIVED
&& sym
->binding_label
[0] != '\0')
7063 gfc_gsymbol
*bind_c_sym
;
7065 bind_c_sym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->binding_label
);
7066 if (bind_c_sym
!= NULL
7067 && strcmp (bind_c_sym
->name
, sym
->binding_label
) == 0)
7069 if (sym
->attr
.if_source
== IFSRC_DECL
7070 && (bind_c_sym
->type
!= GSYM_SUBROUTINE
7071 && bind_c_sym
->type
!= GSYM_FUNCTION
)
7072 && ((sym
->attr
.contained
== 1
7073 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0)
7074 || (sym
->attr
.use_assoc
== 1
7075 && (strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0))))
7077 /* Make sure global procedures don't collide with anything. */
7078 gfc_error ("Binding label '%s' at %L collides with the global "
7079 "entity '%s' at %L", sym
->binding_label
,
7080 &(sym
->declared_at
), bind_c_sym
->name
,
7081 &(bind_c_sym
->where
));
7084 else if (sym
->attr
.contained
== 0
7085 && (sym
->attr
.if_source
== IFSRC_IFBODY
7086 && sym
->attr
.flavor
== FL_PROCEDURE
)
7087 && (bind_c_sym
->sym_name
!= NULL
7088 && strcmp (bind_c_sym
->sym_name
, sym
->name
) != 0))
7090 /* Make sure procedures in interface bodies don't collide. */
7091 gfc_error ("Binding label '%s' in interface body at %L collides "
7092 "with the global entity '%s' at %L",
7094 &(sym
->declared_at
), bind_c_sym
->name
,
7095 &(bind_c_sym
->where
));
7098 else if (sym
->attr
.contained
== 0
7099 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
7100 if ((sym
->attr
.use_assoc
&& bind_c_sym
->mod_name
7101 && strcmp (bind_c_sym
->mod_name
, sym
->module
) != 0)
7102 || sym
->attr
.use_assoc
== 0)
7104 gfc_error ("Binding label '%s' at %L collides with global "
7105 "entity '%s' at %L", sym
->binding_label
,
7106 &(sym
->declared_at
), bind_c_sym
->name
,
7107 &(bind_c_sym
->where
));
7112 /* Clear the binding label to prevent checking multiple times. */
7113 sym
->binding_label
[0] = '\0';
7115 else if (bind_c_sym
== NULL
)
7117 bind_c_sym
= gfc_get_gsymbol (sym
->binding_label
);
7118 bind_c_sym
->where
= sym
->declared_at
;
7119 bind_c_sym
->sym_name
= sym
->name
;
7121 if (sym
->attr
.use_assoc
== 1)
7122 bind_c_sym
->mod_name
= sym
->module
;
7124 if (sym
->ns
->proc_name
!= NULL
)
7125 bind_c_sym
->mod_name
= sym
->ns
->proc_name
->name
;
7127 if (sym
->attr
.contained
== 0)
7129 if (sym
->attr
.subroutine
)
7130 bind_c_sym
->type
= GSYM_SUBROUTINE
;
7131 else if (sym
->attr
.function
)
7132 bind_c_sym
->type
= GSYM_FUNCTION
;
7140 /* Resolve an index expression. */
7143 resolve_index_expr (gfc_expr
*e
)
7145 if (gfc_resolve_expr (e
) == FAILURE
)
7148 if (gfc_simplify_expr (e
, 0) == FAILURE
)
7151 if (gfc_specification_expr (e
) == FAILURE
)
7157 /* Resolve a charlen structure. */
7160 resolve_charlen (gfc_charlen
*cl
)
7169 specification_expr
= 1;
7171 if (resolve_index_expr (cl
->length
) == FAILURE
)
7173 specification_expr
= 0;
7177 /* "If the character length parameter value evaluates to a negative
7178 value, the length of character entities declared is zero." */
7179 if (cl
->length
&& !gfc_extract_int (cl
->length
, &i
) && i
< 0)
7181 gfc_warning_now ("CHARACTER variable has zero length at %L",
7182 &cl
->length
->where
);
7183 gfc_replace_expr (cl
->length
, gfc_int_expr (0));
7190 /* Test for non-constant shape arrays. */
7193 is_non_constant_shape_array (gfc_symbol
*sym
)
7199 not_constant
= false;
7200 if (sym
->as
!= NULL
)
7202 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
7203 has not been simplified; parameter array references. Do the
7204 simplification now. */
7205 for (i
= 0; i
< sym
->as
->rank
; i
++)
7207 e
= sym
->as
->lower
[i
];
7208 if (e
&& (resolve_index_expr (e
) == FAILURE
7209 || !gfc_is_constant_expr (e
)))
7210 not_constant
= true;
7212 e
= sym
->as
->upper
[i
];
7213 if (e
&& (resolve_index_expr (e
) == FAILURE
7214 || !gfc_is_constant_expr (e
)))
7215 not_constant
= true;
7218 return not_constant
;
7221 /* Given a symbol and an initialization expression, add code to initialize
7222 the symbol to the function entry. */
7224 build_init_assign (gfc_symbol
*sym
, gfc_expr
*init
)
7228 gfc_namespace
*ns
= sym
->ns
;
7230 /* Search for the function namespace if this is a contained
7231 function without an explicit result. */
7232 if (sym
->attr
.function
&& sym
== sym
->result
7233 && sym
->name
!= sym
->ns
->proc_name
->name
)
7236 for (;ns
; ns
= ns
->sibling
)
7237 if (strcmp (ns
->proc_name
->name
, sym
->name
) == 0)
7243 gfc_free_expr (init
);
7247 /* Build an l-value expression for the result. */
7248 lval
= gfc_lval_expr_from_sym (sym
);
7250 /* Add the code at scope entry. */
7251 init_st
= gfc_get_code ();
7252 init_st
->next
= ns
->code
;
7255 /* Assign the default initializer to the l-value. */
7256 init_st
->loc
= sym
->declared_at
;
7257 init_st
->op
= EXEC_INIT_ASSIGN
;
7258 init_st
->expr
= lval
;
7259 init_st
->expr2
= init
;
7262 /* Assign the default initializer to a derived type variable or result. */
7265 apply_default_init (gfc_symbol
*sym
)
7267 gfc_expr
*init
= NULL
;
7269 if (sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
7272 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
)
7273 init
= gfc_default_initializer (&sym
->ts
);
7278 build_init_assign (sym
, init
);
7281 /* Build an initializer for a local integer, real, complex, logical, or
7282 character variable, based on the command line flags finit-local-zero,
7283 finit-integer=, finit-real=, finit-logical=, and finit-runtime. Returns
7284 null if the symbol should not have a default initialization. */
7286 build_default_init_expr (gfc_symbol
*sym
)
7289 gfc_expr
*init_expr
;
7292 /* These symbols should never have a default initialization. */
7293 if ((sym
->attr
.dimension
&& !gfc_is_compile_time_shape (sym
->as
))
7294 || sym
->attr
.external
7296 || sym
->attr
.pointer
7297 || sym
->attr
.in_equivalence
7298 || sym
->attr
.in_common
7301 || sym
->attr
.cray_pointee
7302 || sym
->attr
.cray_pointer
)
7305 /* Now we'll try to build an initializer expression. */
7306 init_expr
= gfc_get_expr ();
7307 init_expr
->expr_type
= EXPR_CONSTANT
;
7308 init_expr
->ts
.type
= sym
->ts
.type
;
7309 init_expr
->ts
.kind
= sym
->ts
.kind
;
7310 init_expr
->where
= sym
->declared_at
;
7312 /* We will only initialize integers, reals, complex, logicals, and
7313 characters, and only if the corresponding command-line flags
7314 were set. Otherwise, we free init_expr and return null. */
7315 switch (sym
->ts
.type
)
7318 if (gfc_option
.flag_init_integer
!= GFC_INIT_INTEGER_OFF
)
7319 mpz_init_set_si (init_expr
->value
.integer
,
7320 gfc_option
.flag_init_integer_value
);
7323 gfc_free_expr (init_expr
);
7329 mpfr_init (init_expr
->value
.real
);
7330 switch (gfc_option
.flag_init_real
)
7332 case GFC_INIT_REAL_NAN
:
7333 mpfr_set_nan (init_expr
->value
.real
);
7336 case GFC_INIT_REAL_INF
:
7337 mpfr_set_inf (init_expr
->value
.real
, 1);
7340 case GFC_INIT_REAL_NEG_INF
:
7341 mpfr_set_inf (init_expr
->value
.real
, -1);
7344 case GFC_INIT_REAL_ZERO
:
7345 mpfr_set_ui (init_expr
->value
.real
, 0.0, GFC_RND_MODE
);
7349 gfc_free_expr (init_expr
);
7356 mpfr_init (init_expr
->value
.complex.r
);
7357 mpfr_init (init_expr
->value
.complex.i
);
7358 switch (gfc_option
.flag_init_real
)
7360 case GFC_INIT_REAL_NAN
:
7361 mpfr_set_nan (init_expr
->value
.complex.r
);
7362 mpfr_set_nan (init_expr
->value
.complex.i
);
7365 case GFC_INIT_REAL_INF
:
7366 mpfr_set_inf (init_expr
->value
.complex.r
, 1);
7367 mpfr_set_inf (init_expr
->value
.complex.i
, 1);
7370 case GFC_INIT_REAL_NEG_INF
:
7371 mpfr_set_inf (init_expr
->value
.complex.r
, -1);
7372 mpfr_set_inf (init_expr
->value
.complex.i
, -1);
7375 case GFC_INIT_REAL_ZERO
:
7376 mpfr_set_ui (init_expr
->value
.complex.r
, 0.0, GFC_RND_MODE
);
7377 mpfr_set_ui (init_expr
->value
.complex.i
, 0.0, GFC_RND_MODE
);
7381 gfc_free_expr (init_expr
);
7388 if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_FALSE
)
7389 init_expr
->value
.logical
= 0;
7390 else if (gfc_option
.flag_init_logical
== GFC_INIT_LOGICAL_TRUE
)
7391 init_expr
->value
.logical
= 1;
7394 gfc_free_expr (init_expr
);
7400 /* For characters, the length must be constant in order to
7401 create a default initializer. */
7402 if (gfc_option
.flag_init_character
== GFC_INIT_CHARACTER_ON
7403 && sym
->ts
.cl
->length
7404 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
7406 char_len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
7407 init_expr
->value
.character
.length
= char_len
;
7408 init_expr
->value
.character
.string
= gfc_get_wide_string (char_len
+1);
7409 for (i
= 0; i
< char_len
; i
++)
7410 init_expr
->value
.character
.string
[i
]
7411 = (unsigned char) gfc_option
.flag_init_character_value
;
7415 gfc_free_expr (init_expr
);
7421 gfc_free_expr (init_expr
);
7427 /* Add an initialization expression to a local variable. */
7429 apply_default_init_local (gfc_symbol
*sym
)
7431 gfc_expr
*init
= NULL
;
7433 /* The symbol should be a variable or a function return value. */
7434 if ((sym
->attr
.flavor
!= FL_VARIABLE
&& !sym
->attr
.function
)
7435 || (sym
->attr
.function
&& sym
->result
!= sym
))
7438 /* Try to build the initializer expression. If we can't initialize
7439 this symbol, then init will be NULL. */
7440 init
= build_default_init_expr (sym
);
7444 /* For saved variables, we don't want to add an initializer at
7445 function entry, so we just add a static initializer. */
7446 if (sym
->attr
.save
|| sym
->ns
->save_all
)
7448 /* Don't clobber an existing initializer! */
7449 gcc_assert (sym
->value
== NULL
);
7454 build_init_assign (sym
, init
);
7457 /* Resolution of common features of flavors variable and procedure. */
7460 resolve_fl_var_and_proc (gfc_symbol
*sym
, int mp_flag
)
7462 /* Constraints on deferred shape variable. */
7463 if (sym
->as
== NULL
|| sym
->as
->type
!= AS_DEFERRED
)
7465 if (sym
->attr
.allocatable
)
7467 if (sym
->attr
.dimension
)
7468 gfc_error ("Allocatable array '%s' at %L must have "
7469 "a deferred shape", sym
->name
, &sym
->declared_at
);
7471 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
7472 sym
->name
, &sym
->declared_at
);
7476 if (sym
->attr
.pointer
&& sym
->attr
.dimension
)
7478 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
7479 sym
->name
, &sym
->declared_at
);
7486 if (!mp_flag
&& !sym
->attr
.allocatable
7487 && !sym
->attr
.pointer
&& !sym
->attr
.dummy
)
7489 gfc_error ("Array '%s' at %L cannot have a deferred shape",
7490 sym
->name
, &sym
->declared_at
);
7498 /* Additional checks for symbols with flavor variable and derived
7499 type. To be called from resolve_fl_variable. */
7502 resolve_fl_variable_derived (gfc_symbol
*sym
, int no_init_flag
)
7504 gcc_assert (sym
->ts
.type
== BT_DERIVED
);
7506 /* Check to see if a derived type is blocked from being host
7507 associated by the presence of another class I symbol in the same
7508 namespace. 14.6.1.3 of the standard and the discussion on
7509 comp.lang.fortran. */
7510 if (sym
->ns
!= sym
->ts
.derived
->ns
7511 && sym
->ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
7514 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 0, &s
);
7515 if (s
&& s
->attr
.flavor
!= FL_DERIVED
)
7517 gfc_error ("The type '%s' cannot be host associated at %L "
7518 "because it is blocked by an incompatible object "
7519 "of the same name declared at %L",
7520 sym
->ts
.derived
->name
, &sym
->declared_at
,
7526 /* 4th constraint in section 11.3: "If an object of a type for which
7527 component-initialization is specified (R429) appears in the
7528 specification-part of a module and does not have the ALLOCATABLE
7529 or POINTER attribute, the object shall have the SAVE attribute."
7531 The check for initializers is performed with
7532 has_default_initializer because gfc_default_initializer generates
7533 a hidden default for allocatable components. */
7534 if (!(sym
->value
|| no_init_flag
) && sym
->ns
->proc_name
7535 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7536 && !sym
->ns
->save_all
&& !sym
->attr
.save
7537 && !sym
->attr
.pointer
&& !sym
->attr
.allocatable
7538 && has_default_initializer (sym
->ts
.derived
))
7540 gfc_error("Object '%s' at %L must have the SAVE attribute for "
7541 "default initialization of a component",
7542 sym
->name
, &sym
->declared_at
);
7546 /* Assign default initializer. */
7547 if (!(sym
->value
|| sym
->attr
.pointer
|| sym
->attr
.allocatable
)
7548 && (!no_init_flag
|| sym
->attr
.intent
== INTENT_OUT
))
7550 sym
->value
= gfc_default_initializer (&sym
->ts
);
7557 /* Resolve symbols with flavor variable. */
7560 resolve_fl_variable (gfc_symbol
*sym
, int mp_flag
)
7562 int no_init_flag
, automatic_flag
;
7564 const char *auto_save_msg
;
7566 auto_save_msg
= "Automatic object '%s' at %L cannot have the "
7569 if (resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7572 /* Set this flag to check that variables are parameters of all entries.
7573 This check is effected by the call to gfc_resolve_expr through
7574 is_non_constant_shape_array. */
7575 specification_expr
= 1;
7577 if (sym
->ns
->proc_name
7578 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7579 || sym
->ns
->proc_name
->attr
.is_main_program
)
7580 && !sym
->attr
.use_assoc
7581 && !sym
->attr
.allocatable
7582 && !sym
->attr
.pointer
7583 && is_non_constant_shape_array (sym
))
7585 /* The shape of a main program or module array needs to be
7587 gfc_error ("The module or main program array '%s' at %L must "
7588 "have constant shape", sym
->name
, &sym
->declared_at
);
7589 specification_expr
= 0;
7593 if (sym
->ts
.type
== BT_CHARACTER
)
7595 /* Make sure that character string variables with assumed length are
7597 e
= sym
->ts
.cl
->length
;
7598 if (e
== NULL
&& !sym
->attr
.dummy
&& !sym
->attr
.result
)
7600 gfc_error ("Entity with assumed character length at %L must be a "
7601 "dummy argument or a PARAMETER", &sym
->declared_at
);
7605 if (e
&& sym
->attr
.save
&& !gfc_is_constant_expr (e
))
7607 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7611 if (!gfc_is_constant_expr (e
)
7612 && !(e
->expr_type
== EXPR_VARIABLE
7613 && e
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
7614 && sym
->ns
->proc_name
7615 && (sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
7616 || sym
->ns
->proc_name
->attr
.is_main_program
)
7617 && !sym
->attr
.use_assoc
)
7619 gfc_error ("'%s' at %L must have constant character length "
7620 "in this context", sym
->name
, &sym
->declared_at
);
7625 if (sym
->value
== NULL
&& sym
->attr
.referenced
)
7626 apply_default_init_local (sym
); /* Try to apply a default initialization. */
7628 /* Determine if the symbol may not have an initializer. */
7629 no_init_flag
= automatic_flag
= 0;
7630 if (sym
->attr
.allocatable
|| sym
->attr
.external
|| sym
->attr
.dummy
7631 || sym
->attr
.intrinsic
|| sym
->attr
.result
)
7633 else if (sym
->attr
.dimension
&& !sym
->attr
.pointer
7634 && is_non_constant_shape_array (sym
))
7636 no_init_flag
= automatic_flag
= 1;
7638 /* Also, they must not have the SAVE attribute.
7639 SAVE_IMPLICIT is checked below. */
7640 if (sym
->attr
.save
== SAVE_EXPLICIT
)
7642 gfc_error (auto_save_msg
, sym
->name
, &sym
->declared_at
);
7647 /* Ensure that any initializer is simplified. */
7649 gfc_simplify_expr (sym
->value
, 1);
7651 /* Reject illegal initializers. */
7652 if (!sym
->mark
&& sym
->value
)
7654 if (sym
->attr
.allocatable
)
7655 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
7656 sym
->name
, &sym
->declared_at
);
7657 else if (sym
->attr
.external
)
7658 gfc_error ("External '%s' at %L cannot have an initializer",
7659 sym
->name
, &sym
->declared_at
);
7660 else if (sym
->attr
.dummy
7661 && !(sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.intent
== INTENT_OUT
))
7662 gfc_error ("Dummy '%s' at %L cannot have an initializer",
7663 sym
->name
, &sym
->declared_at
);
7664 else if (sym
->attr
.intrinsic
)
7665 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
7666 sym
->name
, &sym
->declared_at
);
7667 else if (sym
->attr
.result
)
7668 gfc_error ("Function result '%s' at %L cannot have an initializer",
7669 sym
->name
, &sym
->declared_at
);
7670 else if (automatic_flag
)
7671 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
7672 sym
->name
, &sym
->declared_at
);
7679 if (sym
->ts
.type
== BT_DERIVED
)
7680 return resolve_fl_variable_derived (sym
, no_init_flag
);
7686 /* Resolve a procedure. */
7689 resolve_fl_procedure (gfc_symbol
*sym
, int mp_flag
)
7691 gfc_formal_arglist
*arg
;
7693 if (sym
->attr
.ambiguous_interfaces
&& !sym
->attr
.referenced
)
7694 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
7695 "interfaces", sym
->name
, &sym
->declared_at
);
7697 if (sym
->attr
.function
7698 && resolve_fl_var_and_proc (sym
, mp_flag
) == FAILURE
)
7701 if (sym
->ts
.type
== BT_CHARACTER
)
7703 gfc_charlen
*cl
= sym
->ts
.cl
;
7705 if (cl
&& cl
->length
&& gfc_is_constant_expr (cl
->length
)
7706 && resolve_charlen (cl
) == FAILURE
)
7709 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
7711 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
7713 gfc_error ("Character-valued statement function '%s' at %L must "
7714 "have constant length", sym
->name
, &sym
->declared_at
);
7718 if (sym
->attr
.external
&& sym
->formal
== NULL
7719 && cl
&& cl
->length
&& cl
->length
->expr_type
!= EXPR_CONSTANT
)
7721 gfc_error ("Automatic character length function '%s' at %L must "
7722 "have an explicit interface", sym
->name
,
7729 /* Ensure that derived type for are not of a private type. Internal
7730 module procedures are excluded by 2.2.3.3 - i.e., they are not
7731 externally accessible and can access all the objects accessible in
7733 if (!(sym
->ns
->parent
7734 && sym
->ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
)
7735 && gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
7737 gfc_interface
*iface
;
7739 for (arg
= sym
->formal
; arg
; arg
= arg
->next
)
7742 && arg
->sym
->ts
.type
== BT_DERIVED
7743 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7744 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7745 arg
->sym
->ts
.derived
->ns
->default_access
)
7746 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: '%s' is of a "
7747 "PRIVATE type and cannot be a dummy argument"
7748 " of '%s', which is PUBLIC at %L",
7749 arg
->sym
->name
, sym
->name
, &sym
->declared_at
)
7752 /* Stop this message from recurring. */
7753 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7758 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7759 PRIVATE to the containing module. */
7760 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7762 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7765 && arg
->sym
->ts
.type
== BT_DERIVED
7766 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7767 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7768 arg
->sym
->ts
.derived
->ns
->default_access
)
7769 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7770 "'%s' in PUBLIC interface '%s' at %L "
7771 "takes dummy arguments of '%s' which is "
7772 "PRIVATE", iface
->sym
->name
, sym
->name
,
7773 &iface
->sym
->declared_at
,
7774 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7776 /* Stop this message from recurring. */
7777 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7783 /* PUBLIC interfaces may expose PRIVATE procedures that take types
7784 PRIVATE to the containing module. */
7785 for (iface
= sym
->generic
; iface
; iface
= iface
->next
)
7787 for (arg
= iface
->sym
->formal
; arg
; arg
= arg
->next
)
7790 && arg
->sym
->ts
.type
== BT_DERIVED
7791 && !arg
->sym
->ts
.derived
->attr
.use_assoc
7792 && !gfc_check_access (arg
->sym
->ts
.derived
->attr
.access
,
7793 arg
->sym
->ts
.derived
->ns
->default_access
)
7794 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Procedure "
7795 "'%s' in PUBLIC interface '%s' at %L "
7796 "takes dummy arguments of '%s' which is "
7797 "PRIVATE", iface
->sym
->name
, sym
->name
,
7798 &iface
->sym
->declared_at
,
7799 gfc_typename (&arg
->sym
->ts
)) == FAILURE
)
7801 /* Stop this message from recurring. */
7802 arg
->sym
->ts
.derived
->attr
.access
= ACCESS_PUBLIC
;
7809 if (sym
->attr
.function
&& sym
->value
&& sym
->attr
.proc
!= PROC_ST_FUNCTION
7810 && !sym
->attr
.proc_pointer
)
7812 gfc_error ("Function '%s' at %L cannot have an initializer",
7813 sym
->name
, &sym
->declared_at
);
7817 /* An external symbol may not have an initializer because it is taken to be
7818 a procedure. Exception: Procedure Pointers. */
7819 if (sym
->attr
.external
&& sym
->value
&& !sym
->attr
.proc_pointer
)
7821 gfc_error ("External object '%s' at %L may not have an initializer",
7822 sym
->name
, &sym
->declared_at
);
7826 /* An elemental function is required to return a scalar 12.7.1 */
7827 if (sym
->attr
.elemental
&& sym
->attr
.function
&& sym
->as
)
7829 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
7830 "result", sym
->name
, &sym
->declared_at
);
7831 /* Reset so that the error only occurs once. */
7832 sym
->attr
.elemental
= 0;
7836 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
7837 char-len-param shall not be array-valued, pointer-valued, recursive
7838 or pure. ....snip... A character value of * may only be used in the
7839 following ways: (i) Dummy arg of procedure - dummy associates with
7840 actual length; (ii) To declare a named constant; or (iii) External
7841 function - but length must be declared in calling scoping unit. */
7842 if (sym
->attr
.function
7843 && sym
->ts
.type
== BT_CHARACTER
7844 && sym
->ts
.cl
&& sym
->ts
.cl
->length
== NULL
)
7846 if ((sym
->as
&& sym
->as
->rank
) || (sym
->attr
.pointer
)
7847 || (sym
->attr
.recursive
) || (sym
->attr
.pure
))
7849 if (sym
->as
&& sym
->as
->rank
)
7850 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7851 "array-valued", sym
->name
, &sym
->declared_at
);
7853 if (sym
->attr
.pointer
)
7854 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7855 "pointer-valued", sym
->name
, &sym
->declared_at
);
7858 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7859 "pure", sym
->name
, &sym
->declared_at
);
7861 if (sym
->attr
.recursive
)
7862 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
7863 "recursive", sym
->name
, &sym
->declared_at
);
7868 /* Appendix B.2 of the standard. Contained functions give an
7869 error anyway. Fixed-form is likely to be F77/legacy. */
7870 if (!sym
->attr
.contained
&& gfc_current_form
!= FORM_FIXED
)
7871 gfc_notify_std (GFC_STD_F95_OBS
, "CHARACTER(*) function "
7872 "'%s' at %L is obsolescent in fortran 95",
7873 sym
->name
, &sym
->declared_at
);
7876 if (sym
->attr
.is_bind_c
&& sym
->attr
.is_c_interop
!= 1)
7878 gfc_formal_arglist
*curr_arg
;
7879 int has_non_interop_arg
= 0;
7881 if (verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
7882 sym
->common_block
) == FAILURE
)
7884 /* Clear these to prevent looking at them again if there was an
7886 sym
->attr
.is_bind_c
= 0;
7887 sym
->attr
.is_c_interop
= 0;
7888 sym
->ts
.is_c_interop
= 0;
7892 /* So far, no errors have been found. */
7893 sym
->attr
.is_c_interop
= 1;
7894 sym
->ts
.is_c_interop
= 1;
7897 curr_arg
= sym
->formal
;
7898 while (curr_arg
!= NULL
)
7900 /* Skip implicitly typed dummy args here. */
7901 if (curr_arg
->sym
->attr
.implicit_type
== 0)
7902 if (verify_c_interop_param (curr_arg
->sym
) == FAILURE
)
7903 /* If something is found to fail, record the fact so we
7904 can mark the symbol for the procedure as not being
7905 BIND(C) to try and prevent multiple errors being
7907 has_non_interop_arg
= 1;
7909 curr_arg
= curr_arg
->next
;
7912 /* See if any of the arguments were not interoperable and if so, clear
7913 the procedure symbol to prevent duplicate error messages. */
7914 if (has_non_interop_arg
!= 0)
7916 sym
->attr
.is_c_interop
= 0;
7917 sym
->ts
.is_c_interop
= 0;
7918 sym
->attr
.is_bind_c
= 0;
7922 if (sym
->attr
.save
== SAVE_EXPLICIT
&& !sym
->attr
.proc_pointer
)
7924 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
7925 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
7929 if (sym
->attr
.intent
&& !sym
->attr
.proc_pointer
)
7931 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
7932 "in '%s' at %L", sym
->name
, &sym
->declared_at
);
7940 /* Resolve a list of finalizer procedures. That is, after they have hopefully
7941 been defined and we now know their defined arguments, check that they fulfill
7942 the requirements of the standard for procedures used as finalizers. */
7945 gfc_resolve_finalizers (gfc_symbol
* derived
)
7947 gfc_finalizer
* list
;
7948 gfc_finalizer
** prev_link
; /* For removing wrong entries from the list. */
7949 gfc_try result
= SUCCESS
;
7950 bool seen_scalar
= false;
7952 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->finalizers
)
7955 /* Walk over the list of finalizer-procedures, check them, and if any one
7956 does not fit in with the standard's definition, print an error and remove
7957 it from the list. */
7958 prev_link
= &derived
->f2k_derived
->finalizers
;
7959 for (list
= derived
->f2k_derived
->finalizers
; list
; list
= *prev_link
)
7965 /* Skip this finalizer if we already resolved it. */
7966 if (list
->proc_tree
)
7968 prev_link
= &(list
->next
);
7972 /* Check this exists and is a SUBROUTINE. */
7973 if (!list
->proc_sym
->attr
.subroutine
)
7975 gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
7976 list
->proc_sym
->name
, &list
->where
);
7980 /* We should have exactly one argument. */
7981 if (!list
->proc_sym
->formal
|| list
->proc_sym
->formal
->next
)
7983 gfc_error ("FINAL procedure at %L must have exactly one argument",
7987 arg
= list
->proc_sym
->formal
->sym
;
7989 /* This argument must be of our type. */
7990 if (arg
->ts
.type
!= BT_DERIVED
|| arg
->ts
.derived
!= derived
)
7992 gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
7993 &arg
->declared_at
, derived
->name
);
7997 /* It must neither be a pointer nor allocatable nor optional. */
7998 if (arg
->attr
.pointer
)
8000 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
8004 if (arg
->attr
.allocatable
)
8006 gfc_error ("Argument of FINAL procedure at %L must not be"
8007 " ALLOCATABLE", &arg
->declared_at
);
8010 if (arg
->attr
.optional
)
8012 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
8017 /* It must not be INTENT(OUT). */
8018 if (arg
->attr
.intent
== INTENT_OUT
)
8020 gfc_error ("Argument of FINAL procedure at %L must not be"
8021 " INTENT(OUT)", &arg
->declared_at
);
8025 /* Warn if the procedure is non-scalar and not assumed shape. */
8026 if (gfc_option
.warn_surprising
&& arg
->as
&& arg
->as
->rank
> 0
8027 && arg
->as
->type
!= AS_ASSUMED_SHAPE
)
8028 gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
8029 " shape argument", &arg
->declared_at
);
8031 /* Check that it does not match in kind and rank with a FINAL procedure
8032 defined earlier. To really loop over the *earlier* declarations,
8033 we need to walk the tail of the list as new ones were pushed at the
8035 /* TODO: Handle kind parameters once they are implemented. */
8036 my_rank
= (arg
->as
? arg
->as
->rank
: 0);
8037 for (i
= list
->next
; i
; i
= i
->next
)
8039 /* Argument list might be empty; that is an error signalled earlier,
8040 but we nevertheless continued resolving. */
8041 if (i
->proc_sym
->formal
)
8043 gfc_symbol
* i_arg
= i
->proc_sym
->formal
->sym
;
8044 const int i_rank
= (i_arg
->as
? i_arg
->as
->rank
: 0);
8045 if (i_rank
== my_rank
)
8047 gfc_error ("FINAL procedure '%s' declared at %L has the same"
8048 " rank (%d) as '%s'",
8049 list
->proc_sym
->name
, &list
->where
, my_rank
,
8056 /* Is this the/a scalar finalizer procedure? */
8057 if (!arg
->as
|| arg
->as
->rank
== 0)
8060 /* Find the symtree for this procedure. */
8061 gcc_assert (!list
->proc_tree
);
8062 list
->proc_tree
= gfc_find_sym_in_symtree (list
->proc_sym
);
8064 prev_link
= &list
->next
;
8067 /* Remove wrong nodes immediately from the list so we don't risk any
8068 troubles in the future when they might fail later expectations. */
8072 *prev_link
= list
->next
;
8073 gfc_free_finalizer (i
);
8076 /* Warn if we haven't seen a scalar finalizer procedure (but we know there
8077 were nodes in the list, must have been for arrays. It is surely a good
8078 idea to have a scalar version there if there's something to finalize. */
8079 if (gfc_option
.warn_surprising
&& result
== SUCCESS
&& !seen_scalar
)
8080 gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
8081 " defined at %L, suggest also scalar one",
8082 derived
->name
, &derived
->declared_at
);
8084 /* TODO: Remove this error when finalization is finished. */
8085 gfc_error ("Finalization at %L is not yet implemented",
8086 &derived
->declared_at
);
8092 /* Check that it is ok for the typebound procedure proc to override the
8096 check_typebound_override (gfc_symtree
* proc
, gfc_symtree
* old
)
8099 const gfc_symbol
* proc_target
;
8100 const gfc_symbol
* old_target
;
8101 unsigned proc_pass_arg
, old_pass_arg
, argpos
;
8102 gfc_formal_arglist
* proc_formal
;
8103 gfc_formal_arglist
* old_formal
;
8105 /* This procedure should only be called for non-GENERIC proc. */
8106 gcc_assert (!proc
->typebound
->is_generic
);
8108 /* If the overwritten procedure is GENERIC, this is an error. */
8109 if (old
->typebound
->is_generic
)
8111 gfc_error ("Can't overwrite GENERIC '%s' at %L",
8112 old
->name
, &proc
->typebound
->where
);
8116 where
= proc
->typebound
->where
;
8117 proc_target
= proc
->typebound
->u
.specific
->n
.sym
;
8118 old_target
= old
->typebound
->u
.specific
->n
.sym
;
8120 /* Check that overridden binding is not NON_OVERRIDABLE. */
8121 if (old
->typebound
->non_overridable
)
8123 gfc_error ("'%s' at %L overrides a procedure binding declared"
8124 " NON_OVERRIDABLE", proc
->name
, &where
);
8128 /* If the overridden binding is PURE, the overriding must be, too. */
8129 if (old_target
->attr
.pure
&& !proc_target
->attr
.pure
)
8131 gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
8132 proc
->name
, &where
);
8136 /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
8137 is not, the overriding must not be either. */
8138 if (old_target
->attr
.elemental
&& !proc_target
->attr
.elemental
)
8140 gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
8141 " ELEMENTAL", proc
->name
, &where
);
8144 if (!old_target
->attr
.elemental
&& proc_target
->attr
.elemental
)
8146 gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
8147 " be ELEMENTAL, either", proc
->name
, &where
);
8151 /* If the overridden binding is a SUBROUTINE, the overriding must also be a
8153 if (old_target
->attr
.subroutine
&& !proc_target
->attr
.subroutine
)
8155 gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
8156 " SUBROUTINE", proc
->name
, &where
);
8160 /* If the overridden binding is a FUNCTION, the overriding must also be a
8161 FUNCTION and have the same characteristics. */
8162 if (old_target
->attr
.function
)
8164 if (!proc_target
->attr
.function
)
8166 gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
8167 " FUNCTION", proc
->name
, &where
);
8171 /* FIXME: Do more comprehensive checking (including, for instance, the
8172 rank and array-shape). */
8173 gcc_assert (proc_target
->result
&& old_target
->result
);
8174 if (!gfc_compare_types (&proc_target
->result
->ts
,
8175 &old_target
->result
->ts
))
8177 gfc_error ("'%s' at %L and the overridden FUNCTION should have"
8178 " matching result types", proc
->name
, &where
);
8183 /* If the overridden binding is PUBLIC, the overriding one must not be
8185 if (old
->typebound
->access
== ACCESS_PUBLIC
8186 && proc
->typebound
->access
== ACCESS_PRIVATE
)
8188 gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
8189 " PRIVATE", proc
->name
, &where
);
8193 /* Compare the formal argument lists of both procedures. This is also abused
8194 to find the position of the passed-object dummy arguments of both
8195 bindings as at least the overridden one might not yet be resolved and we
8196 need those positions in the check below. */
8197 proc_pass_arg
= old_pass_arg
= 0;
8198 if (!proc
->typebound
->nopass
&& !proc
->typebound
->pass_arg
)
8200 if (!old
->typebound
->nopass
&& !old
->typebound
->pass_arg
)
8203 for (proc_formal
= proc_target
->formal
, old_formal
= old_target
->formal
;
8204 proc_formal
&& old_formal
;
8205 proc_formal
= proc_formal
->next
, old_formal
= old_formal
->next
)
8207 if (proc
->typebound
->pass_arg
8208 && !strcmp (proc
->typebound
->pass_arg
, proc_formal
->sym
->name
))
8209 proc_pass_arg
= argpos
;
8210 if (old
->typebound
->pass_arg
8211 && !strcmp (old
->typebound
->pass_arg
, old_formal
->sym
->name
))
8212 old_pass_arg
= argpos
;
8214 /* Check that the names correspond. */
8215 if (strcmp (proc_formal
->sym
->name
, old_formal
->sym
->name
))
8217 gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
8218 " to match the corresponding argument of the overridden"
8219 " procedure", proc_formal
->sym
->name
, proc
->name
, &where
,
8220 old_formal
->sym
->name
);
8224 /* Check that the types correspond if neither is the passed-object
8226 /* FIXME: Do more comprehensive testing here. */
8227 if (proc_pass_arg
!= argpos
&& old_pass_arg
!= argpos
8228 && !gfc_compare_types (&proc_formal
->sym
->ts
, &old_formal
->sym
->ts
))
8230 gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
8231 " in respect to the overridden procedure",
8232 proc_formal
->sym
->name
, proc
->name
, &where
);
8238 if (proc_formal
|| old_formal
)
8240 gfc_error ("'%s' at %L must have the same number of formal arguments as"
8241 " the overridden procedure", proc
->name
, &where
);
8245 /* If the overridden binding is NOPASS, the overriding one must also be
8247 if (old
->typebound
->nopass
&& !proc
->typebound
->nopass
)
8249 gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
8250 " NOPASS", proc
->name
, &where
);
8254 /* If the overridden binding is PASS(x), the overriding one must also be
8255 PASS and the passed-object dummy arguments must correspond. */
8256 if (!old
->typebound
->nopass
)
8258 if (proc
->typebound
->nopass
)
8260 gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
8261 " PASS", proc
->name
, &where
);
8265 if (proc_pass_arg
!= old_pass_arg
)
8267 gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
8268 " the same position as the passed-object dummy argument of"
8269 " the overridden procedure", proc
->name
, &where
);
8278 /* Check if two GENERIC targets are ambiguous and emit an error is they are. */
8281 check_generic_tbp_ambiguity (gfc_tbp_generic
* t1
, gfc_tbp_generic
* t2
,
8282 const char* generic_name
, locus where
)
8287 gcc_assert (t1
->specific
&& t2
->specific
);
8288 gcc_assert (!t1
->specific
->is_generic
);
8289 gcc_assert (!t2
->specific
->is_generic
);
8291 sym1
= t1
->specific
->u
.specific
->n
.sym
;
8292 sym2
= t2
->specific
->u
.specific
->n
.sym
;
8294 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
8295 if (sym1
->attr
.subroutine
!= sym2
->attr
.subroutine
8296 || sym1
->attr
.function
!= sym2
->attr
.function
)
8298 gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
8299 " GENERIC '%s' at %L",
8300 sym1
->name
, sym2
->name
, generic_name
, &where
);
8304 /* Compare the interfaces. */
8305 if (gfc_compare_interfaces (sym1
, sym2
, 1))
8307 gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
8308 sym1
->name
, sym2
->name
, generic_name
, &where
);
8316 /* Resolve a GENERIC procedure binding for a derived type. */
8319 resolve_typebound_generic (gfc_symbol
* derived
, gfc_symtree
* st
)
8321 gfc_tbp_generic
* target
;
8322 gfc_symtree
* first_target
;
8323 gfc_symbol
* super_type
;
8324 gfc_symtree
* inherited
;
8327 gcc_assert (st
->typebound
);
8328 gcc_assert (st
->typebound
->is_generic
);
8330 where
= st
->typebound
->where
;
8331 super_type
= gfc_get_derived_super_type (derived
);
8333 /* Find the overridden binding if any. */
8334 st
->typebound
->overridden
= NULL
;
8337 gfc_symtree
* overridden
;
8338 overridden
= gfc_find_typebound_proc (super_type
, NULL
, st
->name
, true);
8340 if (overridden
&& overridden
->typebound
)
8341 st
->typebound
->overridden
= overridden
->typebound
;
8344 /* Try to find the specific bindings for the symtrees in our target-list. */
8345 gcc_assert (st
->typebound
->u
.generic
);
8346 for (target
= st
->typebound
->u
.generic
; target
; target
= target
->next
)
8347 if (!target
->specific
)
8349 gfc_typebound_proc
* overridden_tbp
;
8351 const char* target_name
;
8353 target_name
= target
->specific_st
->name
;
8355 /* Defined for this type directly. */
8356 if (target
->specific_st
->typebound
)
8358 target
->specific
= target
->specific_st
->typebound
;
8359 goto specific_found
;
8362 /* Look for an inherited specific binding. */
8365 inherited
= gfc_find_typebound_proc (super_type
, NULL
,
8370 gcc_assert (inherited
->typebound
);
8371 target
->specific
= inherited
->typebound
;
8372 goto specific_found
;
8376 gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
8377 " at %L", target_name
, st
->name
, &where
);
8380 /* Once we've found the specific binding, check it is not ambiguous with
8381 other specifics already found or inherited for the same GENERIC. */
8383 gcc_assert (target
->specific
);
8385 /* This must really be a specific binding! */
8386 if (target
->specific
->is_generic
)
8388 gfc_error ("GENERIC '%s' at %L must target a specific binding,"
8389 " '%s' is GENERIC, too", st
->name
, &where
, target_name
);
8393 /* Check those already resolved on this type directly. */
8394 for (g
= st
->typebound
->u
.generic
; g
; g
= g
->next
)
8395 if (g
!= target
&& g
->specific
8396 && check_generic_tbp_ambiguity (target
, g
, st
->name
, where
)
8400 /* Check for ambiguity with inherited specific targets. */
8401 for (overridden_tbp
= st
->typebound
->overridden
; overridden_tbp
;
8402 overridden_tbp
= overridden_tbp
->overridden
)
8403 if (overridden_tbp
->is_generic
)
8405 for (g
= overridden_tbp
->u
.generic
; g
; g
= g
->next
)
8407 gcc_assert (g
->specific
);
8408 if (check_generic_tbp_ambiguity (target
, g
,
8409 st
->name
, where
) == FAILURE
)
8415 /* If we attempt to "overwrite" a specific binding, this is an error. */
8416 if (st
->typebound
->overridden
&& !st
->typebound
->overridden
->is_generic
)
8418 gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
8419 " the same name", st
->name
, &where
);
8423 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
8424 all must have the same attributes here. */
8425 first_target
= st
->typebound
->u
.generic
->specific
->u
.specific
;
8426 st
->typebound
->subroutine
= first_target
->n
.sym
->attr
.subroutine
;
8427 st
->typebound
->function
= first_target
->n
.sym
->attr
.function
;
8433 /* Resolve the type-bound procedures for a derived type. */
8435 static gfc_symbol
* resolve_bindings_derived
;
8436 static gfc_try resolve_bindings_result
;
8439 resolve_typebound_procedure (gfc_symtree
* stree
)
8444 gfc_symbol
* super_type
;
8445 gfc_component
* comp
;
8447 /* If this is no type-bound procedure, just return. */
8448 if (!stree
->typebound
)
8451 /* If this is a GENERIC binding, use that routine. */
8452 if (stree
->typebound
->is_generic
)
8454 if (resolve_typebound_generic (resolve_bindings_derived
, stree
)
8460 /* Get the target-procedure to check it. */
8461 gcc_assert (!stree
->typebound
->is_generic
);
8462 gcc_assert (stree
->typebound
->u
.specific
);
8463 proc
= stree
->typebound
->u
.specific
->n
.sym
;
8464 where
= stree
->typebound
->where
;
8466 /* Default access should already be resolved from the parser. */
8467 gcc_assert (stree
->typebound
->access
!= ACCESS_UNKNOWN
);
8469 /* It should be a module procedure or an external procedure with explicit
8471 if ((!proc
->attr
.subroutine
&& !proc
->attr
.function
)
8472 || (proc
->attr
.proc
!= PROC_MODULE
8473 && proc
->attr
.if_source
!= IFSRC_IFBODY
)
8474 || proc
->attr
.abstract
)
8476 gfc_error ("'%s' must be a module procedure or an external procedure with"
8477 " an explicit interface at %L", proc
->name
, &where
);
8480 stree
->typebound
->subroutine
= proc
->attr
.subroutine
;
8481 stree
->typebound
->function
= proc
->attr
.function
;
8483 /* Find the super-type of the current derived type. We could do this once and
8484 store in a global if speed is needed, but as long as not I believe this is
8485 more readable and clearer. */
8486 super_type
= gfc_get_derived_super_type (resolve_bindings_derived
);
8488 /* If PASS, resolve and check arguments if not already resolved / loaded
8489 from a .mod file. */
8490 if (!stree
->typebound
->nopass
&& stree
->typebound
->pass_arg_num
== 0)
8492 if (stree
->typebound
->pass_arg
)
8494 gfc_formal_arglist
* i
;
8496 /* If an explicit passing argument name is given, walk the arg-list
8500 stree
->typebound
->pass_arg_num
= 1;
8501 for (i
= proc
->formal
; i
; i
= i
->next
)
8503 if (!strcmp (i
->sym
->name
, stree
->typebound
->pass_arg
))
8508 ++stree
->typebound
->pass_arg_num
;
8513 gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
8515 proc
->name
, stree
->typebound
->pass_arg
, &where
,
8516 stree
->typebound
->pass_arg
);
8522 /* Otherwise, take the first one; there should in fact be at least
8524 stree
->typebound
->pass_arg_num
= 1;
8527 gfc_error ("Procedure '%s' with PASS at %L must have at"
8528 " least one argument", proc
->name
, &where
);
8531 me_arg
= proc
->formal
->sym
;
8534 /* Now check that the argument-type matches. */
8535 gcc_assert (me_arg
);
8536 if (me_arg
->ts
.type
!= BT_DERIVED
8537 || me_arg
->ts
.derived
!= resolve_bindings_derived
)
8539 gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
8540 " the derived-type '%s'", me_arg
->name
, proc
->name
,
8541 me_arg
->name
, &where
, resolve_bindings_derived
->name
);
8545 gfc_warning ("Polymorphic entities are not yet implemented,"
8546 " non-polymorphic passed-object dummy argument of '%s'"
8547 " at %L accepted", proc
->name
, &where
);
8550 /* If we are extending some type, check that we don't override a procedure
8551 flagged NON_OVERRIDABLE. */
8552 stree
->typebound
->overridden
= NULL
;
8555 gfc_symtree
* overridden
;
8556 overridden
= gfc_find_typebound_proc (super_type
, NULL
,
8559 if (overridden
&& overridden
->typebound
)
8560 stree
->typebound
->overridden
= overridden
->typebound
;
8562 if (overridden
&& check_typebound_override (stree
, overridden
) == FAILURE
)
8566 /* See if there's a name collision with a component directly in this type. */
8567 for (comp
= resolve_bindings_derived
->components
; comp
; comp
= comp
->next
)
8568 if (!strcmp (comp
->name
, stree
->name
))
8570 gfc_error ("Procedure '%s' at %L has the same name as a component of"
8572 stree
->name
, &where
, resolve_bindings_derived
->name
);
8576 /* Try to find a name collision with an inherited component. */
8577 if (super_type
&& gfc_find_component (super_type
, stree
->name
, true, true))
8579 gfc_error ("Procedure '%s' at %L has the same name as an inherited"
8580 " component of '%s'",
8581 stree
->name
, &where
, resolve_bindings_derived
->name
);
8585 stree
->typebound
->error
= 0;
8589 resolve_bindings_result
= FAILURE
;
8590 stree
->typebound
->error
= 1;
8594 resolve_typebound_procedures (gfc_symbol
* derived
)
8596 if (!derived
->f2k_derived
|| !derived
->f2k_derived
->sym_root
)
8599 resolve_bindings_derived
= derived
;
8600 resolve_bindings_result
= SUCCESS
;
8601 gfc_traverse_symtree (derived
->f2k_derived
->sym_root
,
8602 &resolve_typebound_procedure
);
8604 return resolve_bindings_result
;
8608 /* Add a derived type to the dt_list. The dt_list is used in trans-types.c
8609 to give all identical derived types the same backend_decl. */
8611 add_dt_to_dt_list (gfc_symbol
*derived
)
8613 gfc_dt_list
*dt_list
;
8615 for (dt_list
= gfc_derived_types
; dt_list
; dt_list
= dt_list
->next
)
8616 if (derived
== dt_list
->derived
)
8619 if (dt_list
== NULL
)
8621 dt_list
= gfc_get_dt_list ();
8622 dt_list
->next
= gfc_derived_types
;
8623 dt_list
->derived
= derived
;
8624 gfc_derived_types
= dt_list
;
8629 /* Resolve the components of a derived type. */
8632 resolve_fl_derived (gfc_symbol
*sym
)
8634 gfc_symbol
* super_type
;
8638 super_type
= gfc_get_derived_super_type (sym
);
8640 /* Ensure the extended type gets resolved before we do. */
8641 if (super_type
&& resolve_fl_derived (super_type
) == FAILURE
)
8644 /* An ABSTRACT type must be extensible. */
8645 if (sym
->attr
.abstract
&& (sym
->attr
.is_bind_c
|| sym
->attr
.sequence
))
8647 gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
8648 sym
->name
, &sym
->declared_at
);
8652 for (c
= sym
->components
; c
!= NULL
; c
= c
->next
)
8654 /* Check type-spec if this is not the parent-type component. */
8655 if ((!sym
->attr
.extension
|| c
!= sym
->components
)
8656 && resolve_typespec_used (&c
->ts
, &c
->loc
, c
->name
) == FAILURE
)
8659 /* If this type is an extension, see if this component has the same name
8660 as an inherited type-bound procedure. */
8662 && gfc_find_typebound_proc (super_type
, NULL
, c
->name
, true))
8664 gfc_error ("Component '%s' of '%s' at %L has the same name as an"
8665 " inherited type-bound procedure",
8666 c
->name
, sym
->name
, &c
->loc
);
8670 if (c
->ts
.type
== BT_CHARACTER
)
8672 if (c
->ts
.cl
->length
== NULL
8673 || (resolve_charlen (c
->ts
.cl
) == FAILURE
)
8674 || !gfc_is_constant_expr (c
->ts
.cl
->length
))
8676 gfc_error ("Character length of component '%s' needs to "
8677 "be a constant specification expression at %L",
8679 c
->ts
.cl
->length
? &c
->ts
.cl
->length
->where
: &c
->loc
);
8684 if (c
->ts
.type
== BT_DERIVED
8685 && sym
->component_access
!= ACCESS_PRIVATE
8686 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
8687 && !c
->ts
.derived
->attr
.use_assoc
8688 && !gfc_check_access (c
->ts
.derived
->attr
.access
,
8689 c
->ts
.derived
->ns
->default_access
))
8691 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
8692 "a component of '%s', which is PUBLIC at %L",
8693 c
->name
, sym
->name
, &sym
->declared_at
);
8697 if (sym
->attr
.sequence
)
8699 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
8701 gfc_error ("Component %s of SEQUENCE type declared at %L does "
8702 "not have the SEQUENCE attribute",
8703 c
->ts
.derived
->name
, &sym
->declared_at
);
8708 if (c
->ts
.type
== BT_DERIVED
&& c
->attr
.pointer
8709 && c
->ts
.derived
->components
== NULL
8710 && !c
->ts
.derived
->attr
.zero_comp
)
8712 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
8713 "that has not been declared", c
->name
, sym
->name
,
8718 /* Ensure that all the derived type components are put on the
8719 derived type list; even in formal namespaces, where derived type
8720 pointer components might not have been declared. */
8721 if (c
->ts
.type
== BT_DERIVED
8723 && c
->ts
.derived
->components
8725 && sym
!= c
->ts
.derived
)
8726 add_dt_to_dt_list (c
->ts
.derived
);
8728 if (c
->attr
.pointer
|| c
->attr
.allocatable
|| c
->as
== NULL
)
8731 for (i
= 0; i
< c
->as
->rank
; i
++)
8733 if (c
->as
->lower
[i
] == NULL
8734 || (resolve_index_expr (c
->as
->lower
[i
]) == FAILURE
)
8735 || !gfc_is_constant_expr (c
->as
->lower
[i
])
8736 || c
->as
->upper
[i
] == NULL
8737 || (resolve_index_expr (c
->as
->upper
[i
]) == FAILURE
)
8738 || !gfc_is_constant_expr (c
->as
->upper
[i
]))
8740 gfc_error ("Component '%s' of '%s' at %L must have "
8741 "constant array bounds",
8742 c
->name
, sym
->name
, &c
->loc
);
8748 /* Resolve the type-bound procedures. */
8749 if (resolve_typebound_procedures (sym
) == FAILURE
)
8752 /* Resolve the finalizer procedures. */
8753 if (gfc_resolve_finalizers (sym
) == FAILURE
)
8756 /* Add derived type to the derived type list. */
8757 add_dt_to_dt_list (sym
);
8764 resolve_fl_namelist (gfc_symbol
*sym
)
8769 /* Reject PRIVATE objects in a PUBLIC namelist. */
8770 if (gfc_check_access(sym
->attr
.access
, sym
->ns
->default_access
))
8772 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8774 if (!nl
->sym
->attr
.use_assoc
8775 && !(sym
->ns
->parent
== nl
->sym
->ns
)
8776 && !(sym
->ns
->parent
8777 && sym
->ns
->parent
->parent
== nl
->sym
->ns
)
8778 && !gfc_check_access(nl
->sym
->attr
.access
,
8779 nl
->sym
->ns
->default_access
))
8781 gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
8782 "cannot be member of PUBLIC namelist '%s' at %L",
8783 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8787 /* Types with private components that came here by USE-association. */
8788 if (nl
->sym
->ts
.type
== BT_DERIVED
8789 && derived_inaccessible (nl
->sym
->ts
.derived
))
8791 gfc_error ("NAMELIST object '%s' has use-associated PRIVATE "
8792 "components and cannot be member of namelist '%s' at %L",
8793 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8797 /* Types with private components that are defined in the same module. */
8798 if (nl
->sym
->ts
.type
== BT_DERIVED
8799 && !(sym
->ns
->parent
== nl
->sym
->ts
.derived
->ns
)
8800 && !gfc_check_access (nl
->sym
->ts
.derived
->attr
.private_comp
8801 ? ACCESS_PRIVATE
: ACCESS_UNKNOWN
,
8802 nl
->sym
->ns
->default_access
))
8804 gfc_error ("NAMELIST object '%s' has PRIVATE components and "
8805 "cannot be a member of PUBLIC namelist '%s' at %L",
8806 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8812 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8814 /* Reject namelist arrays of assumed shape. */
8815 if (nl
->sym
->as
&& nl
->sym
->as
->type
== AS_ASSUMED_SHAPE
8816 && gfc_notify_std (GFC_STD_F2003
, "NAMELIST array object '%s' "
8817 "must not have assumed shape in namelist "
8818 "'%s' at %L", nl
->sym
->name
, sym
->name
,
8819 &sym
->declared_at
) == FAILURE
)
8822 /* Reject namelist arrays that are not constant shape. */
8823 if (is_non_constant_shape_array (nl
->sym
))
8825 gfc_error ("NAMELIST array object '%s' must have constant "
8826 "shape in namelist '%s' at %L", nl
->sym
->name
,
8827 sym
->name
, &sym
->declared_at
);
8831 /* Namelist objects cannot have allocatable or pointer components. */
8832 if (nl
->sym
->ts
.type
!= BT_DERIVED
)
8835 if (nl
->sym
->ts
.derived
->attr
.alloc_comp
)
8837 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8838 "have ALLOCATABLE components",
8839 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8843 if (nl
->sym
->ts
.derived
->attr
.pointer_comp
)
8845 gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
8846 "have POINTER components",
8847 nl
->sym
->name
, sym
->name
, &sym
->declared_at
);
8853 /* 14.1.2 A module or internal procedure represent local entities
8854 of the same type as a namelist member and so are not allowed. */
8855 for (nl
= sym
->namelist
; nl
; nl
= nl
->next
)
8857 if (nl
->sym
->ts
.kind
!= 0 && nl
->sym
->attr
.flavor
== FL_VARIABLE
)
8860 if (nl
->sym
->attr
.function
&& nl
->sym
== nl
->sym
->result
)
8861 if ((nl
->sym
== sym
->ns
->proc_name
)
8863 (sym
->ns
->parent
&& nl
->sym
== sym
->ns
->parent
->proc_name
))
8867 if (nl
->sym
&& nl
->sym
->name
)
8868 gfc_find_symbol (nl
->sym
->name
, sym
->ns
, 1, &nlsym
);
8869 if (nlsym
&& nlsym
->attr
.flavor
== FL_PROCEDURE
)
8871 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
8872 "attribute in '%s' at %L", nlsym
->name
,
8883 resolve_fl_parameter (gfc_symbol
*sym
)
8885 /* A parameter array's shape needs to be constant. */
8887 && (sym
->as
->type
== AS_DEFERRED
8888 || is_non_constant_shape_array (sym
)))
8890 gfc_error ("Parameter array '%s' at %L cannot be automatic "
8891 "or of deferred shape", sym
->name
, &sym
->declared_at
);
8895 /* Make sure a parameter that has been implicitly typed still
8896 matches the implicit type, since PARAMETER statements can precede
8897 IMPLICIT statements. */
8898 if (sym
->attr
.implicit_type
8899 && !gfc_compare_types (&sym
->ts
, gfc_get_default_type (sym
, sym
->ns
)))
8901 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
8902 "later IMPLICIT type", sym
->name
, &sym
->declared_at
);
8906 /* Make sure the types of derived parameters are consistent. This
8907 type checking is deferred until resolution because the type may
8908 refer to a derived type from the host. */
8909 if (sym
->ts
.type
== BT_DERIVED
8910 && !gfc_compare_types (&sym
->ts
, &sym
->value
->ts
))
8912 gfc_error ("Incompatible derived type in PARAMETER at %L",
8913 &sym
->value
->where
);
8920 /* Do anything necessary to resolve a symbol. Right now, we just
8921 assume that an otherwise unknown symbol is a variable. This sort
8922 of thing commonly happens for symbols in module. */
8925 resolve_symbol (gfc_symbol
*sym
)
8927 int check_constant
, mp_flag
;
8928 gfc_symtree
*symtree
;
8929 gfc_symtree
*this_symtree
;
8933 if (sym
->attr
.flavor
== FL_UNKNOWN
)
8936 /* If we find that a flavorless symbol is an interface in one of the
8937 parent namespaces, find its symtree in this namespace, free the
8938 symbol and set the symtree to point to the interface symbol. */
8939 for (ns
= gfc_current_ns
->parent
; ns
; ns
= ns
->parent
)
8941 symtree
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
8942 if (symtree
&& symtree
->n
.sym
->generic
)
8944 this_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
,
8948 gfc_free_symbol (sym
);
8949 symtree
->n
.sym
->refs
++;
8950 this_symtree
->n
.sym
= symtree
->n
.sym
;
8955 /* Otherwise give it a flavor according to such attributes as
8957 if (sym
->attr
.external
== 0 && sym
->attr
.intrinsic
== 0)
8958 sym
->attr
.flavor
= FL_VARIABLE
;
8961 sym
->attr
.flavor
= FL_PROCEDURE
;
8962 if (sym
->attr
.dimension
)
8963 sym
->attr
.function
= 1;
8967 if (sym
->attr
.procedure
&& sym
->ts
.interface
8968 && sym
->attr
.if_source
!= IFSRC_DECL
)
8970 if (sym
->ts
.interface
->attr
.procedure
)
8971 gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
8972 "in a later PROCEDURE statement", sym
->ts
.interface
->name
,
8973 sym
->name
,&sym
->declared_at
);
8975 /* Get the attributes from the interface (now resolved). */
8976 if (sym
->ts
.interface
->attr
.if_source
|| sym
->ts
.interface
->attr
.intrinsic
)
8978 gfc_symbol
*ifc
= sym
->ts
.interface
;
8980 sym
->ts
.interface
= ifc
;
8981 sym
->attr
.function
= ifc
->attr
.function
;
8982 sym
->attr
.subroutine
= ifc
->attr
.subroutine
;
8983 sym
->attr
.allocatable
= ifc
->attr
.allocatable
;
8984 sym
->attr
.pointer
= ifc
->attr
.pointer
;
8985 sym
->attr
.pure
= ifc
->attr
.pure
;
8986 sym
->attr
.elemental
= ifc
->attr
.elemental
;
8987 sym
->attr
.dimension
= ifc
->attr
.dimension
;
8988 sym
->attr
.recursive
= ifc
->attr
.recursive
;
8989 sym
->attr
.always_explicit
= ifc
->attr
.always_explicit
;
8990 copy_formal_args (sym
, ifc
);
8991 /* Copy array spec. */
8992 sym
->as
= gfc_copy_array_spec (ifc
->as
);
8996 for (i
= 0; i
< sym
->as
->rank
; i
++)
8998 gfc_expr_replace_symbols (sym
->as
->lower
[i
], sym
);
8999 gfc_expr_replace_symbols (sym
->as
->upper
[i
], sym
);
9002 /* Copy char length. */
9005 sym
->ts
.cl
= gfc_get_charlen();
9006 sym
->ts
.cl
->resolved
= ifc
->ts
.cl
->resolved
;
9007 sym
->ts
.cl
->length
= gfc_copy_expr (ifc
->ts
.cl
->length
);
9008 gfc_expr_replace_symbols (sym
->ts
.cl
->length
, sym
);
9009 /* Add charlen to namespace. */
9012 sym
->ts
.cl
->next
= sym
->formal_ns
->cl_list
;
9013 sym
->formal_ns
->cl_list
= sym
->ts
.cl
;
9017 else if (sym
->ts
.interface
->name
[0] != '\0')
9019 gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
9020 sym
->ts
.interface
->name
, sym
->name
, &sym
->declared_at
);
9025 if (sym
->attr
.flavor
== FL_DERIVED
&& resolve_fl_derived (sym
) == FAILURE
)
9028 /* Symbols that are module procedures with results (functions) have
9029 the types and array specification copied for type checking in
9030 procedures that call them, as well as for saving to a module
9031 file. These symbols can't stand the scrutiny that their results
9033 mp_flag
= (sym
->result
!= NULL
&& sym
->result
!= sym
);
9036 /* Make sure that the intrinsic is consistent with its internal
9037 representation. This needs to be done before assigning a default
9038 type to avoid spurious warnings. */
9039 if (sym
->attr
.flavor
!= FL_MODULE
&& sym
->attr
.intrinsic
)
9041 gfc_intrinsic_sym
* isym
;
9044 /* We already know this one is an intrinsic, so we don't call
9045 gfc_is_intrinsic for full checking but rather use gfc_find_function and
9046 gfc_find_subroutine directly to check whether it is a function or
9049 if ((isym
= gfc_find_function (sym
->name
)))
9051 if (sym
->ts
.type
!= BT_UNKNOWN
&& gfc_option
.warn_surprising
)
9052 gfc_warning ("Type specified for intrinsic function '%s' at %L is"
9053 " ignored", sym
->name
, &sym
->declared_at
);
9055 else if ((isym
= gfc_find_subroutine (sym
->name
)))
9057 if (sym
->ts
.type
!= BT_UNKNOWN
)
9059 gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
9060 " specifier", sym
->name
, &sym
->declared_at
);
9066 gfc_error ("'%s' declared INTRINSIC at %L does not exist",
9067 sym
->name
, &sym
->declared_at
);
9071 /* Check it is actually available in the standard settings. */
9072 if (gfc_check_intrinsic_standard (isym
, &symstd
, false, sym
->declared_at
)
9075 gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
9076 " available in the current standard settings but %s. Use"
9077 " an appropriate -std=* option or enable -fall-intrinsics"
9078 " in order to use it.",
9079 sym
->name
, &sym
->declared_at
, symstd
);
9084 /* Assign default type to symbols that need one and don't have one. */
9085 if (sym
->ts
.type
== BT_UNKNOWN
)
9087 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
)
9088 gfc_set_default_type (sym
, 1, NULL
);
9090 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
)
9092 /* The specific case of an external procedure should emit an error
9093 in the case that there is no implicit type. */
9095 gfc_set_default_type (sym
, sym
->attr
.external
, NULL
);
9098 /* Result may be in another namespace. */
9099 resolve_symbol (sym
->result
);
9101 sym
->ts
= sym
->result
->ts
;
9102 sym
->as
= gfc_copy_array_spec (sym
->result
->as
);
9103 sym
->attr
.dimension
= sym
->result
->attr
.dimension
;
9104 sym
->attr
.pointer
= sym
->result
->attr
.pointer
;
9105 sym
->attr
.allocatable
= sym
->result
->attr
.allocatable
;
9110 /* Assumed size arrays and assumed shape arrays must be dummy
9114 && (sym
->as
->type
== AS_ASSUMED_SIZE
9115 || sym
->as
->type
== AS_ASSUMED_SHAPE
)
9116 && sym
->attr
.dummy
== 0)
9118 if (sym
->as
->type
== AS_ASSUMED_SIZE
)
9119 gfc_error ("Assumed size array at %L must be a dummy argument",
9122 gfc_error ("Assumed shape array at %L must be a dummy argument",
9127 /* Make sure symbols with known intent or optional are really dummy
9128 variable. Because of ENTRY statement, this has to be deferred
9129 until resolution time. */
9131 if (!sym
->attr
.dummy
9132 && (sym
->attr
.optional
|| sym
->attr
.intent
!= INTENT_UNKNOWN
))
9134 gfc_error ("Symbol at %L is not a DUMMY variable", &sym
->declared_at
);
9138 if (sym
->attr
.value
&& !sym
->attr
.dummy
)
9140 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
9141 "it is not a dummy argument", sym
->name
, &sym
->declared_at
);
9145 if (sym
->attr
.value
&& sym
->ts
.type
== BT_CHARACTER
)
9147 gfc_charlen
*cl
= sym
->ts
.cl
;
9148 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
)
9150 gfc_error ("Character dummy variable '%s' at %L with VALUE "
9151 "attribute must have constant length",
9152 sym
->name
, &sym
->declared_at
);
9156 if (sym
->ts
.is_c_interop
9157 && mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
9159 gfc_error ("C interoperable character dummy variable '%s' at %L "
9160 "with VALUE attribute must have length one",
9161 sym
->name
, &sym
->declared_at
);
9166 /* If the symbol is marked as bind(c), verify it's type and kind. Do not
9167 do this for something that was implicitly typed because that is handled
9168 in gfc_set_default_type. Handle dummy arguments and procedure
9169 definitions separately. Also, anything that is use associated is not
9170 handled here but instead is handled in the module it is declared in.
9171 Finally, derived type definitions are allowed to be BIND(C) since that
9172 only implies that they're interoperable, and they are checked fully for
9173 interoperability when a variable is declared of that type. */
9174 if (sym
->attr
.is_bind_c
&& sym
->attr
.implicit_type
== 0 &&
9175 sym
->attr
.use_assoc
== 0 && sym
->attr
.dummy
== 0 &&
9176 sym
->attr
.flavor
!= FL_PROCEDURE
&& sym
->attr
.flavor
!= FL_DERIVED
)
9178 gfc_try t
= SUCCESS
;
9180 /* First, make sure the variable is declared at the
9181 module-level scope (J3/04-007, Section 15.3). */
9182 if (sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
&&
9183 sym
->attr
.in_common
== 0)
9185 gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
9186 "is neither a COMMON block nor declared at the "
9187 "module level scope", sym
->name
, &(sym
->declared_at
));
9190 else if (sym
->common_head
!= NULL
)
9192 t
= verify_com_block_vars_c_interop (sym
->common_head
);
9196 /* If type() declaration, we need to verify that the components
9197 of the given type are all C interoperable, etc. */
9198 if (sym
->ts
.type
== BT_DERIVED
&&
9199 sym
->ts
.derived
->attr
.is_c_interop
!= 1)
9201 /* Make sure the user marked the derived type as BIND(C). If
9202 not, call the verify routine. This could print an error
9203 for the derived type more than once if multiple variables
9204 of that type are declared. */
9205 if (sym
->ts
.derived
->attr
.is_bind_c
!= 1)
9206 verify_bind_c_derived_type (sym
->ts
.derived
);
9210 /* Verify the variable itself as C interoperable if it
9211 is BIND(C). It is not possible for this to succeed if
9212 the verify_bind_c_derived_type failed, so don't have to handle
9213 any error returned by verify_bind_c_derived_type. */
9214 t
= verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
9220 /* clear the is_bind_c flag to prevent reporting errors more than
9221 once if something failed. */
9222 sym
->attr
.is_bind_c
= 0;
9227 /* If a derived type symbol has reached this point, without its
9228 type being declared, we have an error. Notice that most
9229 conditions that produce undefined derived types have already
9230 been dealt with. However, the likes of:
9231 implicit type(t) (t) ..... call foo (t) will get us here if
9232 the type is not declared in the scope of the implicit
9233 statement. Change the type to BT_UNKNOWN, both because it is so
9234 and to prevent an ICE. */
9235 if (sym
->ts
.type
== BT_DERIVED
&& sym
->ts
.derived
->components
== NULL
9236 && !sym
->ts
.derived
->attr
.zero_comp
)
9238 gfc_error ("The derived type '%s' at %L is of type '%s', "
9239 "which has not been defined", sym
->name
,
9240 &sym
->declared_at
, sym
->ts
.derived
->name
);
9241 sym
->ts
.type
= BT_UNKNOWN
;
9245 /* Make sure that the derived type has been resolved and that the
9246 derived type is visible in the symbol's namespace, if it is a
9247 module function and is not PRIVATE. */
9248 if (sym
->ts
.type
== BT_DERIVED
9249 && sym
->ts
.derived
->attr
.use_assoc
9250 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)
9254 if (resolve_fl_derived (sym
->ts
.derived
) == FAILURE
)
9257 gfc_find_symbol (sym
->ts
.derived
->name
, sym
->ns
, 1, &ds
);
9258 if (!ds
&& sym
->attr
.function
9259 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
9261 symtree
= gfc_new_symtree (&sym
->ns
->sym_root
,
9262 sym
->ts
.derived
->name
);
9263 symtree
->n
.sym
= sym
->ts
.derived
;
9264 sym
->ts
.derived
->refs
++;
9268 /* Unless the derived-type declaration is use associated, Fortran 95
9269 does not allow public entries of private derived types.
9270 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation
9272 if (sym
->ts
.type
== BT_DERIVED
9273 && sym
->ns
->proc_name
&& sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
9274 && !sym
->ts
.derived
->attr
.use_assoc
9275 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
9276 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
9277 sym
->ts
.derived
->ns
->default_access
)
9278 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC %s '%s' at %L "
9279 "of PRIVATE derived type '%s'",
9280 (sym
->attr
.flavor
== FL_PARAMETER
) ? "parameter"
9281 : "variable", sym
->name
, &sym
->declared_at
,
9282 sym
->ts
.derived
->name
) == FAILURE
)
9285 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
9286 default initialization is defined (5.1.2.4.4). */
9287 if (sym
->ts
.type
== BT_DERIVED
9289 && sym
->attr
.intent
== INTENT_OUT
9291 && sym
->as
->type
== AS_ASSUMED_SIZE
)
9293 for (c
= sym
->ts
.derived
->components
; c
; c
= c
->next
)
9297 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
9298 "ASSUMED SIZE and so cannot have a default initializer",
9299 sym
->name
, &sym
->declared_at
);
9305 switch (sym
->attr
.flavor
)
9308 if (resolve_fl_variable (sym
, mp_flag
) == FAILURE
)
9313 if (resolve_fl_procedure (sym
, mp_flag
) == FAILURE
)
9318 if (resolve_fl_namelist (sym
) == FAILURE
)
9323 if (resolve_fl_parameter (sym
) == FAILURE
)
9331 /* Resolve array specifier. Check as well some constraints
9332 on COMMON blocks. */
9334 check_constant
= sym
->attr
.in_common
&& !sym
->attr
.pointer
;
9336 /* Set the formal_arg_flag so that check_conflict will not throw
9337 an error for host associated variables in the specification
9338 expression for an array_valued function. */
9339 if (sym
->attr
.function
&& sym
->as
)
9340 formal_arg_flag
= 1;
9342 gfc_resolve_array_spec (sym
->as
, check_constant
);
9344 formal_arg_flag
= 0;
9346 /* Resolve formal namespaces. */
9347 if (sym
->formal_ns
&& sym
->formal_ns
!= gfc_current_ns
)
9348 gfc_resolve (sym
->formal_ns
);
9350 /* Check threadprivate restrictions. */
9351 if (sym
->attr
.threadprivate
&& !sym
->attr
.save
&& !sym
->ns
->save_all
9352 && (!sym
->attr
.in_common
9353 && sym
->module
== NULL
9354 && (sym
->ns
->proc_name
== NULL
9355 || sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)))
9356 gfc_error ("Threadprivate at %L isn't SAVEd", &sym
->declared_at
);
9358 /* If we have come this far we can apply default-initializers, as
9359 described in 14.7.5, to those variables that have not already
9360 been assigned one. */
9361 if (sym
->ts
.type
== BT_DERIVED
9362 && sym
->attr
.referenced
9363 && sym
->ns
== gfc_current_ns
9365 && !sym
->attr
.allocatable
9366 && !sym
->attr
.alloc_comp
)
9368 symbol_attribute
*a
= &sym
->attr
;
9370 if ((!a
->save
&& !a
->dummy
&& !a
->pointer
9371 && !a
->in_common
&& !a
->use_assoc
9372 && !(a
->function
&& sym
!= sym
->result
))
9373 || (a
->dummy
&& a
->intent
== INTENT_OUT
))
9374 apply_default_init (sym
);
9377 /* If this symbol has a type-spec, check it. */
9378 if (sym
->attr
.flavor
== FL_VARIABLE
|| sym
->attr
.flavor
== FL_PARAMETER
9379 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.function
))
9380 if (resolve_typespec_used (&sym
->ts
, &sym
->declared_at
, sym
->name
)
9386 /************* Resolve DATA statements *************/
9390 gfc_data_value
*vnode
;
9396 /* Advance the values structure to point to the next value in the data list. */
9399 next_data_value (void)
9402 while (mpz_cmp_ui (values
.left
, 0) == 0)
9404 if (values
.vnode
->next
== NULL
)
9407 values
.vnode
= values
.vnode
->next
;
9408 mpz_set (values
.left
, values
.vnode
->repeat
);
9416 check_data_variable (gfc_data_variable
*var
, locus
*where
)
9422 ar_type mark
= AR_UNKNOWN
;
9424 mpz_t section_index
[GFC_MAX_DIMENSIONS
];
9428 if (gfc_resolve_expr (var
->expr
) == FAILURE
)
9432 mpz_init_set_si (offset
, 0);
9435 if (e
->expr_type
!= EXPR_VARIABLE
)
9436 gfc_internal_error ("check_data_variable(): Bad expression");
9438 if (e
->symtree
->n
.sym
->ns
->is_block_data
9439 && !e
->symtree
->n
.sym
->attr
.in_common
)
9441 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
9442 e
->symtree
->n
.sym
->name
, &e
->symtree
->n
.sym
->declared_at
);
9445 if (e
->ref
== NULL
&& e
->symtree
->n
.sym
->as
)
9447 gfc_error ("DATA array '%s' at %L must be specified in a previous"
9448 " declaration", e
->symtree
->n
.sym
->name
, where
);
9454 mpz_init_set_ui (size
, 1);
9461 /* Find the array section reference. */
9462 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
9464 if (ref
->type
!= REF_ARRAY
)
9466 if (ref
->u
.ar
.type
== AR_ELEMENT
)
9472 /* Set marks according to the reference pattern. */
9473 switch (ref
->u
.ar
.type
)
9481 /* Get the start position of array section. */
9482 gfc_get_section_index (ar
, section_index
, &offset
);
9490 if (gfc_array_size (e
, &size
) == FAILURE
)
9492 gfc_error ("Nonconstant array section at %L in DATA statement",
9501 while (mpz_cmp_ui (size
, 0) > 0)
9503 if (next_data_value () == FAILURE
)
9505 gfc_error ("DATA statement at %L has more variables than values",
9511 t
= gfc_check_assign (var
->expr
, values
.vnode
->expr
, 0);
9515 /* If we have more than one element left in the repeat count,
9516 and we have more than one element left in the target variable,
9517 then create a range assignment. */
9518 /* FIXME: Only done for full arrays for now, since array sections
9520 if (mark
== AR_FULL
&& ref
&& ref
->next
== NULL
9521 && mpz_cmp_ui (values
.left
, 1) > 0 && mpz_cmp_ui (size
, 1) > 0)
9525 if (mpz_cmp (size
, values
.left
) >= 0)
9527 mpz_init_set (range
, values
.left
);
9528 mpz_sub (size
, size
, values
.left
);
9529 mpz_set_ui (values
.left
, 0);
9533 mpz_init_set (range
, size
);
9534 mpz_sub (values
.left
, values
.left
, size
);
9535 mpz_set_ui (size
, 0);
9538 gfc_assign_data_value_range (var
->expr
, values
.vnode
->expr
,
9541 mpz_add (offset
, offset
, range
);
9545 /* Assign initial value to symbol. */
9548 mpz_sub_ui (values
.left
, values
.left
, 1);
9549 mpz_sub_ui (size
, size
, 1);
9551 t
= gfc_assign_data_value (var
->expr
, values
.vnode
->expr
, offset
);
9555 if (mark
== AR_FULL
)
9556 mpz_add_ui (offset
, offset
, 1);
9558 /* Modify the array section indexes and recalculate the offset
9559 for next element. */
9560 else if (mark
== AR_SECTION
)
9561 gfc_advance_section (section_index
, ar
, &offset
);
9565 if (mark
== AR_SECTION
)
9567 for (i
= 0; i
< ar
->dimen
; i
++)
9568 mpz_clear (section_index
[i
]);
9578 static gfc_try
traverse_data_var (gfc_data_variable
*, locus
*);
9580 /* Iterate over a list of elements in a DATA statement. */
9583 traverse_data_list (gfc_data_variable
*var
, locus
*where
)
9586 iterator_stack frame
;
9587 gfc_expr
*e
, *start
, *end
, *step
;
9588 gfc_try retval
= SUCCESS
;
9590 mpz_init (frame
.value
);
9592 start
= gfc_copy_expr (var
->iter
.start
);
9593 end
= gfc_copy_expr (var
->iter
.end
);
9594 step
= gfc_copy_expr (var
->iter
.step
);
9596 if (gfc_simplify_expr (start
, 1) == FAILURE
9597 || start
->expr_type
!= EXPR_CONSTANT
)
9599 gfc_error ("iterator start at %L does not simplify", &start
->where
);
9603 if (gfc_simplify_expr (end
, 1) == FAILURE
9604 || end
->expr_type
!= EXPR_CONSTANT
)
9606 gfc_error ("iterator end at %L does not simplify", &end
->where
);
9610 if (gfc_simplify_expr (step
, 1) == FAILURE
9611 || step
->expr_type
!= EXPR_CONSTANT
)
9613 gfc_error ("iterator step at %L does not simplify", &step
->where
);
9618 mpz_init_set (trip
, end
->value
.integer
);
9619 mpz_sub (trip
, trip
, start
->value
.integer
);
9620 mpz_add (trip
, trip
, step
->value
.integer
);
9622 mpz_div (trip
, trip
, step
->value
.integer
);
9624 mpz_set (frame
.value
, start
->value
.integer
);
9626 frame
.prev
= iter_stack
;
9627 frame
.variable
= var
->iter
.var
->symtree
;
9628 iter_stack
= &frame
;
9630 while (mpz_cmp_ui (trip
, 0) > 0)
9632 if (traverse_data_var (var
->list
, where
) == FAILURE
)
9639 e
= gfc_copy_expr (var
->expr
);
9640 if (gfc_simplify_expr (e
, 1) == FAILURE
)
9648 mpz_add (frame
.value
, frame
.value
, step
->value
.integer
);
9650 mpz_sub_ui (trip
, trip
, 1);
9655 mpz_clear (frame
.value
);
9657 gfc_free_expr (start
);
9658 gfc_free_expr (end
);
9659 gfc_free_expr (step
);
9661 iter_stack
= frame
.prev
;
9666 /* Type resolve variables in the variable list of a DATA statement. */
9669 traverse_data_var (gfc_data_variable
*var
, locus
*where
)
9673 for (; var
; var
= var
->next
)
9675 if (var
->expr
== NULL
)
9676 t
= traverse_data_list (var
, where
);
9678 t
= check_data_variable (var
, where
);
9688 /* Resolve the expressions and iterators associated with a data statement.
9689 This is separate from the assignment checking because data lists should
9690 only be resolved once. */
9693 resolve_data_variables (gfc_data_variable
*d
)
9695 for (; d
; d
= d
->next
)
9697 if (d
->list
== NULL
)
9699 if (gfc_resolve_expr (d
->expr
) == FAILURE
)
9704 if (gfc_resolve_iterator (&d
->iter
, false) == FAILURE
)
9707 if (resolve_data_variables (d
->list
) == FAILURE
)
9716 /* Resolve a single DATA statement. We implement this by storing a pointer to
9717 the value list into static variables, and then recursively traversing the
9718 variables list, expanding iterators and such. */
9721 resolve_data (gfc_data
*d
)
9724 if (resolve_data_variables (d
->var
) == FAILURE
)
9727 values
.vnode
= d
->value
;
9728 if (d
->value
== NULL
)
9729 mpz_set_ui (values
.left
, 0);
9731 mpz_set (values
.left
, d
->value
->repeat
);
9733 if (traverse_data_var (d
->var
, &d
->where
) == FAILURE
)
9736 /* At this point, we better not have any values left. */
9738 if (next_data_value () == SUCCESS
)
9739 gfc_error ("DATA statement at %L has more values than variables",
9744 /* 12.6 Constraint: In a pure subprogram any variable which is in common or
9745 accessed by host or use association, is a dummy argument to a pure function,
9746 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
9747 is storage associated with any such variable, shall not be used in the
9748 following contexts: (clients of this function). */
9750 /* Determines if a variable is not 'pure', i.e., not assignable within a pure
9751 procedure. Returns zero if assignment is OK, nonzero if there is a
9754 gfc_impure_variable (gfc_symbol
*sym
)
9758 if (sym
->attr
.use_assoc
|| sym
->attr
.in_common
)
9761 if (sym
->ns
!= gfc_current_ns
)
9762 return !sym
->attr
.function
;
9764 proc
= sym
->ns
->proc_name
;
9765 if (sym
->attr
.dummy
&& gfc_pure (proc
)
9766 && ((proc
->attr
.subroutine
&& sym
->attr
.intent
== INTENT_IN
)
9768 proc
->attr
.function
))
9771 /* TODO: Sort out what can be storage associated, if anything, and include
9772 it here. In principle equivalences should be scanned but it does not
9773 seem to be possible to storage associate an impure variable this way. */
9778 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
9779 symbol of the current procedure. */
9782 gfc_pure (gfc_symbol
*sym
)
9784 symbol_attribute attr
;
9787 sym
= gfc_current_ns
->proc_name
;
9793 return attr
.flavor
== FL_PROCEDURE
&& (attr
.pure
|| attr
.elemental
);
9797 /* Test whether the current procedure is elemental or not. */
9800 gfc_elemental (gfc_symbol
*sym
)
9802 symbol_attribute attr
;
9805 sym
= gfc_current_ns
->proc_name
;
9810 return attr
.flavor
== FL_PROCEDURE
&& attr
.elemental
;
9814 /* Warn about unused labels. */
9817 warn_unused_fortran_label (gfc_st_label
*label
)
9822 warn_unused_fortran_label (label
->left
);
9824 if (label
->defined
== ST_LABEL_UNKNOWN
)
9827 switch (label
->referenced
)
9829 case ST_LABEL_UNKNOWN
:
9830 gfc_warning ("Label %d at %L defined but not used", label
->value
,
9834 case ST_LABEL_BAD_TARGET
:
9835 gfc_warning ("Label %d at %L defined but cannot be used",
9836 label
->value
, &label
->where
);
9843 warn_unused_fortran_label (label
->right
);
9847 /* Returns the sequence type of a symbol or sequence. */
9850 sequence_type (gfc_typespec ts
)
9859 if (ts
.derived
->components
== NULL
)
9860 return SEQ_NONDEFAULT
;
9862 result
= sequence_type (ts
.derived
->components
->ts
);
9863 for (c
= ts
.derived
->components
->next
; c
; c
= c
->next
)
9864 if (sequence_type (c
->ts
) != result
)
9870 if (ts
.kind
!= gfc_default_character_kind
)
9871 return SEQ_NONDEFAULT
;
9873 return SEQ_CHARACTER
;
9876 if (ts
.kind
!= gfc_default_integer_kind
)
9877 return SEQ_NONDEFAULT
;
9882 if (!(ts
.kind
== gfc_default_real_kind
9883 || ts
.kind
== gfc_default_double_kind
))
9884 return SEQ_NONDEFAULT
;
9889 if (ts
.kind
!= gfc_default_complex_kind
)
9890 return SEQ_NONDEFAULT
;
9895 if (ts
.kind
!= gfc_default_logical_kind
)
9896 return SEQ_NONDEFAULT
;
9901 return SEQ_NONDEFAULT
;
9906 /* Resolve derived type EQUIVALENCE object. */
9909 resolve_equivalence_derived (gfc_symbol
*derived
, gfc_symbol
*sym
, gfc_expr
*e
)
9912 gfc_component
*c
= derived
->components
;
9917 /* Shall not be an object of nonsequence derived type. */
9918 if (!derived
->attr
.sequence
)
9920 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
9921 "attribute to be an EQUIVALENCE object", sym
->name
,
9926 /* Shall not have allocatable components. */
9927 if (derived
->attr
.alloc_comp
)
9929 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
9930 "components to be an EQUIVALENCE object",sym
->name
,
9935 if (sym
->attr
.in_common
&& has_default_initializer (sym
->ts
.derived
))
9937 gfc_error ("Derived type variable '%s' at %L with default "
9938 "initialization cannot be in EQUIVALENCE with a variable "
9939 "in COMMON", sym
->name
, &e
->where
);
9943 for (; c
; c
= c
->next
)
9947 && (resolve_equivalence_derived (c
->ts
.derived
, sym
, e
) == FAILURE
))
9950 /* Shall not be an object of sequence derived type containing a pointer
9951 in the structure. */
9952 if (c
->attr
.pointer
)
9954 gfc_error ("Derived type variable '%s' at %L with pointer "
9955 "component(s) cannot be an EQUIVALENCE object",
9956 sym
->name
, &e
->where
);
9964 /* Resolve equivalence object.
9965 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
9966 an allocatable array, an object of nonsequence derived type, an object of
9967 sequence derived type containing a pointer at any level of component
9968 selection, an automatic object, a function name, an entry name, a result
9969 name, a named constant, a structure component, or a subobject of any of
9970 the preceding objects. A substring shall not have length zero. A
9971 derived type shall not have components with default initialization nor
9972 shall two objects of an equivalence group be initialized.
9973 Either all or none of the objects shall have an protected attribute.
9974 The simple constraints are done in symbol.c(check_conflict) and the rest
9975 are implemented here. */
9978 resolve_equivalence (gfc_equiv
*eq
)
9981 gfc_symbol
*derived
;
9982 gfc_symbol
*first_sym
;
9985 locus
*last_where
= NULL
;
9986 seq_type eq_type
, last_eq_type
;
9987 gfc_typespec
*last_ts
;
9988 int object
, cnt_protected
;
9989 const char *value_name
;
9993 last_ts
= &eq
->expr
->symtree
->n
.sym
->ts
;
9995 first_sym
= eq
->expr
->symtree
->n
.sym
;
9999 for (object
= 1; eq
; eq
= eq
->eq
, object
++)
10003 e
->ts
= e
->symtree
->n
.sym
->ts
;
10004 /* match_varspec might not know yet if it is seeing
10005 array reference or substring reference, as it doesn't
10007 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
)
10009 gfc_ref
*ref
= e
->ref
;
10010 sym
= e
->symtree
->n
.sym
;
10012 if (sym
->attr
.dimension
)
10014 ref
->u
.ar
.as
= sym
->as
;
10018 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
10019 if (e
->ts
.type
== BT_CHARACTER
10021 && ref
->type
== REF_ARRAY
10022 && ref
->u
.ar
.dimen
== 1
10023 && ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
10024 && ref
->u
.ar
.stride
[0] == NULL
)
10026 gfc_expr
*start
= ref
->u
.ar
.start
[0];
10027 gfc_expr
*end
= ref
->u
.ar
.end
[0];
10030 /* Optimize away the (:) reference. */
10031 if (start
== NULL
&& end
== NULL
)
10034 e
->ref
= ref
->next
;
10036 e
->ref
->next
= ref
->next
;
10041 ref
->type
= REF_SUBSTRING
;
10043 start
= gfc_int_expr (1);
10044 ref
->u
.ss
.start
= start
;
10045 if (end
== NULL
&& e
->ts
.cl
)
10046 end
= gfc_copy_expr (e
->ts
.cl
->length
);
10047 ref
->u
.ss
.end
= end
;
10048 ref
->u
.ss
.length
= e
->ts
.cl
;
10055 /* Any further ref is an error. */
10058 gcc_assert (ref
->type
== REF_ARRAY
);
10059 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
10065 if (gfc_resolve_expr (e
) == FAILURE
)
10068 sym
= e
->symtree
->n
.sym
;
10070 if (sym
->attr
.is_protected
)
10072 if (cnt_protected
> 0 && cnt_protected
!= object
)
10074 gfc_error ("Either all or none of the objects in the "
10075 "EQUIVALENCE set at %L shall have the "
10076 "PROTECTED attribute",
10081 /* Shall not equivalence common block variables in a PURE procedure. */
10082 if (sym
->ns
->proc_name
10083 && sym
->ns
->proc_name
->attr
.pure
10084 && sym
->attr
.in_common
)
10086 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
10087 "object in the pure procedure '%s'",
10088 sym
->name
, &e
->where
, sym
->ns
->proc_name
->name
);
10092 /* Shall not be a named constant. */
10093 if (e
->expr_type
== EXPR_CONSTANT
)
10095 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
10096 "object", sym
->name
, &e
->where
);
10100 derived
= e
->ts
.derived
;
10101 if (derived
&& resolve_equivalence_derived (derived
, sym
, e
) == FAILURE
)
10104 /* Check that the types correspond correctly:
10106 A numeric sequence structure may be equivalenced to another sequence
10107 structure, an object of default integer type, default real type, double
10108 precision real type, default logical type such that components of the
10109 structure ultimately only become associated to objects of the same
10110 kind. A character sequence structure may be equivalenced to an object
10111 of default character kind or another character sequence structure.
10112 Other objects may be equivalenced only to objects of the same type and
10113 kind parameters. */
10115 /* Identical types are unconditionally OK. */
10116 if (object
== 1 || gfc_compare_types (last_ts
, &sym
->ts
))
10117 goto identical_types
;
10119 last_eq_type
= sequence_type (*last_ts
);
10120 eq_type
= sequence_type (sym
->ts
);
10122 /* Since the pair of objects is not of the same type, mixed or
10123 non-default sequences can be rejected. */
10125 msg
= "Sequence %s with mixed components in EQUIVALENCE "
10126 "statement at %L with different type objects";
10128 && last_eq_type
== SEQ_MIXED
10129 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
, last_where
)
10131 || (eq_type
== SEQ_MIXED
10132 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10133 &e
->where
) == FAILURE
))
10136 msg
= "Non-default type object or sequence %s in EQUIVALENCE "
10137 "statement at %L with objects of different type";
10139 && last_eq_type
== SEQ_NONDEFAULT
10140 && gfc_notify_std (GFC_STD_GNU
, msg
, first_sym
->name
,
10141 last_where
) == FAILURE
)
10142 || (eq_type
== SEQ_NONDEFAULT
10143 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10144 &e
->where
) == FAILURE
))
10147 msg
="Non-CHARACTER object '%s' in default CHARACTER "
10148 "EQUIVALENCE statement at %L";
10149 if (last_eq_type
== SEQ_CHARACTER
10150 && eq_type
!= SEQ_CHARACTER
10151 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10152 &e
->where
) == FAILURE
)
10155 msg
="Non-NUMERIC object '%s' in default NUMERIC "
10156 "EQUIVALENCE statement at %L";
10157 if (last_eq_type
== SEQ_NUMERIC
10158 && eq_type
!= SEQ_NUMERIC
10159 && gfc_notify_std (GFC_STD_GNU
, msg
, sym
->name
,
10160 &e
->where
) == FAILURE
)
10165 last_where
= &e
->where
;
10170 /* Shall not be an automatic array. */
10171 if (e
->ref
->type
== REF_ARRAY
10172 && gfc_resolve_array_spec (e
->ref
->u
.ar
.as
, 1) == FAILURE
)
10174 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
10175 "an EQUIVALENCE object", sym
->name
, &e
->where
);
10182 /* Shall not be a structure component. */
10183 if (r
->type
== REF_COMPONENT
)
10185 gfc_error ("Structure component '%s' at %L cannot be an "
10186 "EQUIVALENCE object",
10187 r
->u
.c
.component
->name
, &e
->where
);
10191 /* A substring shall not have length zero. */
10192 if (r
->type
== REF_SUBSTRING
)
10194 if (compare_bound (r
->u
.ss
.start
, r
->u
.ss
.end
) == CMP_GT
)
10196 gfc_error ("Substring at %L has length zero",
10197 &r
->u
.ss
.start
->where
);
10207 /* Resolve function and ENTRY types, issue diagnostics if needed. */
10210 resolve_fntype (gfc_namespace
*ns
)
10212 gfc_entry_list
*el
;
10215 if (ns
->proc_name
== NULL
|| !ns
->proc_name
->attr
.function
)
10218 /* If there are any entries, ns->proc_name is the entry master
10219 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
10221 sym
= ns
->entries
->sym
;
10223 sym
= ns
->proc_name
;
10224 if (sym
->result
== sym
10225 && sym
->ts
.type
== BT_UNKNOWN
10226 && gfc_set_default_type (sym
, 0, NULL
) == FAILURE
10227 && !sym
->attr
.untyped
)
10229 gfc_error ("Function '%s' at %L has no IMPLICIT type",
10230 sym
->name
, &sym
->declared_at
);
10231 sym
->attr
.untyped
= 1;
10234 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.use_assoc
10235 && !sym
->attr
.contained
10236 && !gfc_check_access (sym
->ts
.derived
->attr
.access
,
10237 sym
->ts
.derived
->ns
->default_access
)
10238 && gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
10240 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: PUBLIC function '%s' at "
10241 "%L of PRIVATE type '%s'", sym
->name
,
10242 &sym
->declared_at
, sym
->ts
.derived
->name
);
10246 for (el
= ns
->entries
->next
; el
; el
= el
->next
)
10248 if (el
->sym
->result
== el
->sym
10249 && el
->sym
->ts
.type
== BT_UNKNOWN
10250 && gfc_set_default_type (el
->sym
, 0, NULL
) == FAILURE
10251 && !el
->sym
->attr
.untyped
)
10253 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
10254 el
->sym
->name
, &el
->sym
->declared_at
);
10255 el
->sym
->attr
.untyped
= 1;
10260 /* 12.3.2.1.1 Defined operators. */
10263 gfc_resolve_uops (gfc_symtree
*symtree
)
10265 gfc_interface
*itr
;
10267 gfc_formal_arglist
*formal
;
10269 if (symtree
== NULL
)
10272 gfc_resolve_uops (symtree
->left
);
10273 gfc_resolve_uops (symtree
->right
);
10275 for (itr
= symtree
->n
.uop
->op
; itr
; itr
= itr
->next
)
10278 if (!sym
->attr
.function
)
10279 gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
10280 sym
->name
, &sym
->declared_at
);
10282 if (sym
->ts
.type
== BT_CHARACTER
10283 && !(sym
->ts
.cl
&& sym
->ts
.cl
->length
)
10284 && !(sym
->result
&& sym
->result
->ts
.cl
10285 && sym
->result
->ts
.cl
->length
))
10286 gfc_error ("User operator procedure '%s' at %L cannot be assumed "
10287 "character length", sym
->name
, &sym
->declared_at
);
10289 formal
= sym
->formal
;
10290 if (!formal
|| !formal
->sym
)
10292 gfc_error ("User operator procedure '%s' at %L must have at least "
10293 "one argument", sym
->name
, &sym
->declared_at
);
10297 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
10298 gfc_error ("First argument of operator interface at %L must be "
10299 "INTENT(IN)", &sym
->declared_at
);
10301 if (formal
->sym
->attr
.optional
)
10302 gfc_error ("First argument of operator interface at %L cannot be "
10303 "optional", &sym
->declared_at
);
10305 formal
= formal
->next
;
10306 if (!formal
|| !formal
->sym
)
10309 if (formal
->sym
->attr
.intent
!= INTENT_IN
)
10310 gfc_error ("Second argument of operator interface at %L must be "
10311 "INTENT(IN)", &sym
->declared_at
);
10313 if (formal
->sym
->attr
.optional
)
10314 gfc_error ("Second argument of operator interface at %L cannot be "
10315 "optional", &sym
->declared_at
);
10318 gfc_error ("Operator interface at %L must have, at most, two "
10319 "arguments", &sym
->declared_at
);
10324 /* Examine all of the expressions associated with a program unit,
10325 assign types to all intermediate expressions, make sure that all
10326 assignments are to compatible types and figure out which names
10327 refer to which functions or subroutines. It doesn't check code
10328 block, which is handled by resolve_code. */
10331 resolve_types (gfc_namespace
*ns
)
10337 gfc_namespace
* old_ns
= gfc_current_ns
;
10339 /* Check that all IMPLICIT types are ok. */
10340 if (!ns
->seen_implicit_none
)
10343 for (letter
= 0; letter
!= GFC_LETTERS
; ++letter
)
10344 if (ns
->set_flag
[letter
]
10345 && resolve_typespec_used (&ns
->default_type
[letter
],
10346 &ns
->implicit_loc
[letter
],
10351 gfc_current_ns
= ns
;
10353 resolve_entries (ns
);
10355 resolve_common_vars (ns
->blank_common
.head
, false);
10356 resolve_common_blocks (ns
->common_root
);
10358 resolve_contained_functions (ns
);
10360 gfc_traverse_ns (ns
, resolve_bind_c_derived_types
);
10362 for (cl
= ns
->cl_list
; cl
; cl
= cl
->next
)
10363 resolve_charlen (cl
);
10365 gfc_traverse_ns (ns
, resolve_symbol
);
10367 resolve_fntype (ns
);
10369 for (n
= ns
->contained
; n
; n
= n
->sibling
)
10371 if (gfc_pure (ns
->proc_name
) && !gfc_pure (n
->proc_name
))
10372 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
10373 "also be PURE", n
->proc_name
->name
,
10374 &n
->proc_name
->declared_at
);
10380 gfc_check_interfaces (ns
);
10382 gfc_traverse_ns (ns
, resolve_values
);
10388 for (d
= ns
->data
; d
; d
= d
->next
)
10392 gfc_traverse_ns (ns
, gfc_formalize_init_value
);
10394 gfc_traverse_ns (ns
, gfc_verify_binding_labels
);
10396 if (ns
->common_root
!= NULL
)
10397 gfc_traverse_symtree (ns
->common_root
, resolve_bind_c_comms
);
10399 for (eq
= ns
->equiv
; eq
; eq
= eq
->next
)
10400 resolve_equivalence (eq
);
10402 /* Warn about unused labels. */
10403 if (warn_unused_label
)
10404 warn_unused_fortran_label (ns
->st_labels
);
10406 gfc_resolve_uops (ns
->uop_root
);
10408 gfc_current_ns
= old_ns
;
10412 /* Call resolve_code recursively. */
10415 resolve_codes (gfc_namespace
*ns
)
10419 for (n
= ns
->contained
; n
; n
= n
->sibling
)
10422 gfc_current_ns
= ns
;
10424 /* Set to an out of range value. */
10425 current_entry_id
= -1;
10427 bitmap_obstack_initialize (&labels_obstack
);
10428 resolve_code (ns
->code
, ns
);
10429 bitmap_obstack_release (&labels_obstack
);
10433 /* This function is called after a complete program unit has been compiled.
10434 Its purpose is to examine all of the expressions associated with a program
10435 unit, assign types to all intermediate expressions, make sure that all
10436 assignments are to compatible types and figure out which names refer to
10437 which functions or subroutines. */
10440 gfc_resolve (gfc_namespace
*ns
)
10442 gfc_namespace
*old_ns
;
10444 old_ns
= gfc_current_ns
;
10446 resolve_types (ns
);
10447 resolve_codes (ns
);
10449 gfc_current_ns
= old_ns
;